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 (characterp char)
 391       (if (encode-char char '=ucs)
 392           (mapconcat
 393            (lambda (byte)
 394              (format "%%%02X" byte))
 395            (encode-coding-string (char-to-string char) 'utf-8-mcs-er)
 396            "")
 397         (let ((ccs-list '(; =ucs
 398                           =cns11643-1 =cns11643-2 =cns11643-3
 399                           =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
 400                           =gb2312 =gb12345
 401                           =jis-x0208 =jis-x0208@1990
 402                           =jis-x0212
 403                           =cbeta =jef-china3
 404                           =jis-x0213-1@2000 =jis-x0213-1@2004
 405                           =jis-x0208@1983 =jis-x0208@1978
 406                           =zinbun-oracle =>zinbun-oracle
 407                           =daikanwa
 408                           =gt =gt-k
 409                           =>>jis-x0208 =>>jis-x0213-1
 410                           =>jis-x0208 =>jis-x0213-1
 411                           =>>gt
 412                           =ruimoku-v6
 413                           =big5
 414                           =big5-cdp))
 415               ccs ret)
 416           (while (and ccs-list
 417                       (setq ccs (pop ccs-list))
 418                       (not (setq ret (encode-char char ccs 'defined-only)))))
 419           (cond (ret
 420                  (format "%s:0x%X"
 421                          (www-uri-encode-feature-name ccs)
 422                          ret))
 423                 ((and (setq ccs (car (split-char char)))
 424                       (setq ret (encode-char char ccs)))
 425                  (format "%s:0x%X"
 426                          (www-uri-encode-feature-name ccs)
 427                          ret))
 428                 (t
 429                  (format "system-char-id:0x%X"
 430                          (encode-char char 'system-char-id))
 431                  ))))
 432     (format "rep.id:%s" (concord-object-id char))))
 433
 434 (defun est-format-object (object)
 435   (if (characterp object)
 436       (char-to-string object)
 437     (format "%s" (concord-object-id object))))
 438
 439
 440 ;;; @ Feature name presentation
 441 ;;;
 442
 443 (defun www-format-feature-name-default (feature-name)
 444   (mapconcat
 445    #'capitalize
 446    (split-string
 447     (symbol-name feature-name)
 448     "-")
 449    " "))
 450
 451 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
 452   (let ((str (symbol-name feature-name))
 453         base meta)
 454     (cond
 455      ((string-match "\\*[^*]+$" str)
 456       (setq base (substring str 0 (match-beginning 0))
 457             meta (substring str (match-beginning 0)))
 458       (concat (www-format-feature-name* (intern base) lang)
 459               meta))
 460      (t
 461       (www-format-feature-name-default feature-name)
 462       ))))
 463
 464 (defun www-format-feature-name-as-rel-to (feature-name)
 465   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 466
 467 (defun www-format-feature-name-as-rel-from (feature-name)
 468   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 469
 470 (defun www-format-feature-name-as-CCS (feature-name)
 471   (let* ((rest
 472           (split-string
 473            (symbol-name feature-name)
 474            "-"))
 475          (dest (upcase (pop rest))))
 476     (when (string-match "^=+>*" dest)
 477       (setq dest (concat (substring dest 0 (match-end 0))
 478                          " "
 479                          (substring dest (match-end 0)))))
 480     (cond
 481      (rest
 482       (while (cdr rest)
 483         (setq dest (concat dest " " (upcase (pop rest)))))
 484       (if (string-match "^[0-9]+$" (car rest))
 485           (concat dest "-" (car rest))
 486         (concat dest " " (upcase (car rest))))
 487       )
 488      (t dest))))
 489
 490 (defun www-format-feature-name* (feature-name &optional lang)
 491   (let (name fn parent ret)
 492     (cond
 493      ((or (and lang
 494                (char-feature-property
 495                 feature-name
 496                 (intern (format "name@%s" lang))))
 497           (char-feature-property
 498            feature-name 'name)))
 499      ((and (setq name (symbol-name feature-name))
 500            (string-match "\\*" name))
 501       (www-format-feature-name-as-metadata feature-name lang))
 502      (t
 503       (setq fn feature-name)
 504       (while (and (setq parent (char-feature-name-parent fn))
 505                   (null (setq ret
 506                               (or (and lang
 507                                        (char-feature-property
 508                                         parent
 509                                         (intern (format "name@%s" lang))))
 510                                   (char-feature-property
 511                                    parent 'name)))))
 512         (setq fn parent))
 513       (cond
 514        (ret
 515         (concat ret (substring (symbol-name feature-name)
 516                                (length (symbol-name parent)))))
 517        ((find-charset feature-name)
 518         (www-format-feature-name-as-CCS feature-name))
 519        ((string-match "^\\(->\\)" name)
 520         (www-format-feature-name-as-rel-to feature-name))
 521        ((string-match "^\\(<-\\)" name)
 522         (www-format-feature-name-as-rel-from feature-name))
 523        (t
 524         (www-format-feature-name-default feature-name)
 525         ))
 526       ))))
 527
 528 (defun www-format-feature-name (feature-name &optional lang)
 529   (www-format-encode-string
 530    (www-format-feature-name* feature-name lang)))
 531
 532
 533 ;;; @ Feature value presentation
 534 ;;;
 535
 536 (defun www-format-value-as-kuten (value)
 537   (format "%02d-%02d"
 538           (- (lsh value -8) 32)
 539           (- (logand value 255) 32)))
 540
 541 (defun www-format-value-default (value &optional without-tags)
 542   (if (listp value)
 543       (mapconcat
 544        (lambda (unit)
 545          (www-format-encode-string
 546           (format "%S" unit)
 547           without-tags))
 548        value " ")
 549     (www-format-encode-string (format "%S" value) without-tags)))
 550
 551 (defun www-format-value-as-char-list (value &optional without-tags)
 552   (if (listp value)
 553       (mapconcat
 554        (if without-tags
 555            (lambda (unit)
 556              (www-format-encode-string
 557               (format (if (characterp unit)
 558                           "%c"
 559                         "%s")
 560                       unit)
 561               'without-tags))
 562          (let (genre-o name-f ret)
 563            (lambda (unit)
 564              (if (characterp unit)
 565                  (format "<a href=\"%s?char=%s\">%s</a>"
 566                          chise-wiki-view-url
 567                          (www-uri-encode-char unit)
 568                          (www-format-encode-string (char-to-string unit)))
 569                (format "<a href=\"%s?%s=%s\">%s</a>"
 570                        chise-wiki-view-url
 571                        (concord-object-genre unit)
 572                        (concord-object-id unit)
 573                        (cond
 574                         ((setq ret
 575                                (www-get-feature-value
 576                                 unit
 577                                 (setq name-f
 578                                       (if (setq genre-o
 579                                                 (concord-decode-object
 580                                                  '=id
 581                                                  (concord-object-genre unit)
 582                                                  'genre))
 583                                           (www-get-feature-value genre-o 'name)
 584                                         'name))))
 585                          (www-format-eval-feature-value
 586                           unit name-f nil nil nil ret
 587                           'without-tags 'without-edit)
 588                          )
 589                         (t
 590                          (www-format-encode-string
 591                           (format "%S" unit))
 592                          ))
 593                        unit)))))
 594        value " ")
 595     (www-format-encode-string (format "%s" value) without-tags)))
 596
 597 (defun www-format-value-as-domain-list (value &optional without-tags)
 598   (let (name source0 source num dest rest unit start end ddest)
 599     (if (listp value)
 600         (if without-tags
 601             (mapconcat
 602              (lambda (unit)
 603                (format "%s" unit))
 604              value " ")
 605           (setq rest value)
 606           (while rest
 607             (setq unit (pop rest))
 608             (if (symbolp unit)
 609                 (setq name (symbol-name unit)))
 610             (setq dest
 611                   (concat
 612                    dest
 613                    (cond
 614                     ((string-match "^zob1968=" name)
 615                      (setq source (intern (substring name 0 (match-end 0)))
 616                            num (substring name (match-end 0)))
 617                      (if (string-match "^\\([0-9]+\\)-\\([0-9]+\\)$" num)
 618                          (setq start (string-to-number
 619                                       (match-string 1 num))
 620                                end (string-to-number
 621                                     (match-string 2 num)))
 622                        (setq start (string-to-number num)
 623                              end start))
 624                      (setq ddest
 625                            (if (eq source source0)
 626                                (format
 627                                 ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
 628                                 start start)
 629                              (setq source0 source)
 630                              (format
 631                               " <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>"
 632                               (www-format-encode-string "\u4EAC大人\u6587研甲\u9AA8")
 633                               start start)))
 634                      (setq start (1+ start))
 635                      (while (<= start end)
 636                        (setq ddest
 637                              (concat
 638                               ddest
 639                               (format
 640                                ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
 641                                start start)))
 642                        (setq start (1+ start)))
 643                      ddest)
 644                     (t
 645                      (setq source unit)
 646                      (if (eq source source0)
 647                          ""
 648                        (setq source0 source)
 649                        (concat " " name))
 650                      )))))
 651           dest)
 652       (www-format-encode-string (format "%s" value) without-tags))))
 653
 654 (defun www-format-value-as-ids (value &optional without-tags)
 655   (if (listp value)
 656       (mapconcat
 657        (if without-tags
 658            (lambda (unit)
 659              (www-format-encode-string
 660               (format (if (characterp unit)
 661                           "%c"
 662                         "%s")
 663                       unit)
 664               'without-tags))
 665          (lambda (unit)
 666            (if (characterp unit)
 667                (format "<a href=\"%s?char=%s\">%s</a>"
 668                        chise-wiki-view-url
 669                        (www-uri-encode-char unit)
 670                        (www-format-encode-string (char-to-string unit)))
 671              (www-format-encode-string (format "%s" unit)))))
 672        (ideographic-structure-to-ids value) " ")
 673     (www-format-encode-string (format "%s" value) without-tags)))
 674
 675 (defun www-format-value-as-S-exp (value &optional without-tags)
 676   (www-format-encode-string (format "%S" value) without-tags))
 677
 678 (defun www-format-value-as-HEX (value)
 679   (if (integerp value)
 680       (format "%X" value)
 681     (www-format-value-as-S-exp value)))
 682
 683 (defun www-format-value-as-CCS-default (value)
 684   (if (integerp value)
 685       (format "0x%s (%d)"
 686               (www-format-value-as-HEX value)
 687               value)
 688     (www-format-value-as-S-exp value)))
 689
 690 (defun www-format-value-as-CCS-94x94 (value)
 691   (if (integerp value)
 692       (format "0x%s [%s] (%d)"
 693               (www-format-value-as-HEX value)
 694               (www-format-value-as-kuten value)
 695               value)
 696     (www-format-value-as-S-exp value)))
 697
 698 (defun www-format-value-as-kangxi-radical (value)
 699   (if (and (integerp value)
 700            (<= 0 value)
 701            (<= value 214))
 702       (www-format-encode-string
 703        (format "%c" (ideographic-radical value)))
 704     (www-format-value-as-S-exp value)))
 705
 706 (defun www-format-value (object feature-name
 707                                 &optional value format
 708                                 without-tags without-edit)
 709   (unless value
 710     (setq value (www-get-feature-value object feature-name)))
 711   (www-format-apply-value object feature-name
 712                           format nil value nil nil
 713                           without-tags without-edit)
 714   )
 715
 716
 717 ;;; @ format evaluator
 718 ;;;
 719
 720 (defun www-format-encode-string (string &optional without-tags)
 721   (with-temp-buffer
 722     (insert string)
 723     (let (plane code start end char variants ret rret)
 724       (goto-char (point-min))
 725       (while (search-forward "<" nil t)
 726         (replace-match "&lt;" nil t))
 727       (goto-char (point-min))
 728       (while (search-forward ">" nil t)
 729         (replace-match "&gt;" nil t))
 730       (if without-tags
 731           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 732         (let ((coded-charset-entity-reference-alist
 733                (list*
 734                 '(=gt                   "GT-" 5 d)
 735                 '(=cns11643-1           "C1-" 4 X)
 736                 '(=cns11643-2           "C2-" 4 X)
 737                 '(=cns11643-3           "C3-" 4 X)
 738                 '(=cns11643-4           "C4-" 4 X)
 739                 '(=cns11643-5           "C5-" 4 X)
 740                 '(=cns11643-6           "C6-" 4 X)
 741                 '(=cns11643-7           "C7-" 4 X)
 742                 '(=gb2312               "G0-" 4 X)
 743                 '(=gb12345              "G1-" 4 X)
 744                 '(=jis-x0208@1990       "J90-" 4 X)
 745                 '(=jis-x0212            "JSP-" 4 X)
 746                 '(=cbeta                "CB" 5 d)
 747                 '(=jis-x0208@1997       "J97-" 4 X)
 748                 '(=jis-x0208@1978       "J78-" 4 X)
 749                 '(=jis-x0208@1983       "J83-" 4 X)
 750                 '(=ruimoku-v6           "RUI6-" 4 X)
 751                 '(=zinbun-oracle        "ZOB-" 4 d)
 752                 '(=jef-china3           "JC3-" 4 X)
 753                 '(=daikanwa             "M-" 5 d)
 754                 coded-charset-entity-reference-alist)))
 755           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 756
 757           (goto-char (point-min))
 758           (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
 759             (setq code (string-to-int (match-string 1)))
 760             (replace-match
 761              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\">"
 762                      code
 763                      chise-wiki-bitmap-glyphs-url
 764                      (/ code 1000) code)
 765              t 'literal))
 766
 767           (goto-char (point-min))
 768           (while (re-search-forward "&J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 769             (setq plane (match-string 1)
 770                   code (string-to-int (match-string 2) 16))
 771             (replace-match
 772              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\">"
 773                      plane code
 774                      chise-wiki-bitmap-glyphs-url
 775                      plane
 776                      (- (lsh code -8) 32)
 777                      (- (logand code 255) 32))
 778              t 'literal))
 779
 780           (goto-char (point-min))
 781           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 782             (setq plane (string-to-int (match-string 1))
 783                   code (string-to-int (match-string 2) 16))
 784             (replace-match
 785              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\">"
 786                      plane code
 787                      chise-wiki-bitmap-glyphs-url
 788                      plane
 789                      (- (lsh code -8) 32)
 790                      (- (logand code 255) 32))
 791              t 'literal))
 792
 793           (goto-char (point-min))
 794           (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 795             (setq plane (string-to-int (match-string 1))
 796                   code (string-to-int (match-string 2) 16))
 797             (replace-match
 798              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\">"
 799                      plane code
 800                      chise-wiki-bitmap-glyphs-url
 801                      plane code)
 802              t 'literal))
 803
 804           (goto-char (point-min))
 805           (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 806             (setq code (string-to-int (match-string 1) 16))
 807             (replace-match
 808              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 809                      code code)
 810              t 'literal))
 811
 812           (goto-char (point-min))
 813           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
 814             (setq code (string-to-int (match-string 2)))
 815             (replace-match
 816              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\">"
 817                      code
 818                      chise-wiki-bitmap-glyphs-url
 819                      code)
 820              t 'literal))
 821
 822           (goto-char (point-min))
 823           (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
 824             (setq code (string-to-int (match-string 2)))
 825             (replace-match
 826              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\">"
 827                      code
 828                      chise-wiki-glyph-cgi-url
 829                      code)
 830              t 'literal))
 831
 832           (goto-char (point-min))
 833           (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
 834             (setq code (string-to-int (match-string 2)))
 835             (replace-match
 836              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\">"
 837                      code
 838                      chise-wiki-glyph-cgi-url
 839                      code)
 840              t 'literal))
 841
 842           (goto-char (point-min))
 843           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
 844             (setq code (string-to-int (match-string 1) 16))
 845             (replace-match
 846              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\">"
 847                      code
 848                      chise-wiki-glyph-cgi-url
 849                      code)
 850              t 'literal))
 851
 852           (goto-char (point-min))
 853           (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
 854             (setq code (string-to-int (match-string 1) 16))
 855             (replace-match
 856              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\">"
 857                      code
 858                      chise-wiki-glyph-cgi-url
 859                      code)
 860              t 'literal))
 861
 862           (goto-char (point-min))
 863           (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
 864             (setq code (string-to-int (match-string 1) 16))
 865             (replace-match
 866              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\">"
 867                      code
 868                      chise-wiki-glyph-cgi-url
 869                      code)
 870              t 'literal))
 871
 872           (goto-char (point-min))
 873           (while (re-search-forward "&\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
 874             (setq code (string-to-int (match-string 2) 16))
 875             (replace-match
 876              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\">"
 877                      code
 878                      code)
 879              t 'literal))
 880
 881           (goto-char (point-min))
 882           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
 883             (setq code (string-to-int (match-string 1) 16))
 884             (setq start (match-beginning 0)
 885                   end (match-end 0))
 886             (setq char (decode-char 'system-char-id code))
 887             (cond
 888              ((and (setq variants
 889                          (or (www-get-feature-value char '->subsumptive)
 890                              (www-get-feature-value char '->denotational)))
 891                    (progn
 892                      (while (and variants
 893                                  (setq ret (www-format-encode-string
 894                                             (char-to-string (car variants))))
 895                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
 896                        (setq variants (cdr variants)))
 897                      ret))
 898               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
 899                 (goto-char start)
 900                 (delete-region start end)
 901                 (insert ret))
 902               )
 903              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
 904                             (www-get-feature-value char 'ideographic-structure)))
 905               (setq ret
 906                     (mapconcat
 907                      (lambda (ch)
 908                        (if (listp ch)
 909                            (if (characterp (setq rret (find-char ch)))
 910                                (setq ch rret)))
 911                        (if (characterp ch)
 912                            (www-format-encode-string
 913                             (char-to-string ch) without-tags)
 914                          (www-format-encode-string
 915                           (format "%S" ch) without-tags)))
 916                      ret ""))
 917               (when ret
 918                 (goto-char start)
 919                 (delete-region start end)
 920                 (insert ret))
 921               )))
 922           ))
 923       ;; (goto-char (point-min))
 924       ;; (while (search-forward "&GT-" nil t)
 925       ;;   (replace-match "&amp;GT-" t 'literal))
 926       (buffer-string))))
 927
 928 (defun www-format-props-to-string (props &optional format)
 929   (unless format
 930     (setq format (plist-get props :format)))
 931   (concat "%"
 932           (plist-get props :flag)
 933           ;; (if (plist-get props :zero-padding)
 934           ;;     "0")
 935           (if (plist-get props :len)
 936               (format "0%d"
 937                       (let ((ret (plist-get props :len)))
 938                         (if (stringp ret)
 939                             (string-to-int ret)
 940                           ret))))
 941           (cond
 942            ((eq format 'decimal) "d")
 943            ((eq format 'hex) "x")
 944            ((eq format 'HEX) "X")
 945            ((eq format 'S-exp) "S")
 946            (t "s"))))
 947
 948 (defun www-format-apply-value (object feature-name
 949                                       format props value
 950                                       &optional uri-object uri-feature
 951                                       without-tags without-edit)
 952   (let (ret)
 953     (setq ret
 954           (cond
 955            ((memq format '(decimal hex HEX))
 956             (if (integerp value)
 957                 (format (www-format-props-to-string props format)
 958                         value)
 959               (www-format-encode-string
 960                (format "%s" value)
 961                without-tags))
 962             )
 963            ((eq format 'wiki-text)
 964             (if without-tags
 965                 (www-xml-format-list value)
 966               (www-format-eval-list value object feature-name nil uri-object
 967                                     without-tags without-edit))
 968             )
 969            ((eq format 'S-exp)
 970             (www-format-encode-string
 971              (format (www-format-props-to-string props format)
 972                      value)
 973              without-tags))
 974            ((eq format 'ku-ten)
 975             (www-format-value-as-kuten value))
 976            ((eq format 'kangxi-radical)
 977             (www-format-value-as-kangxi-radical value))
 978            ((eq format 'space-separated-char-list)
 979             (www-format-value-as-char-list value without-tags))
 980            ((eq format 'space-separated-ids)
 981             (www-format-value-as-ids value without-tags))
 982            ((eq format 'space-separated-domain-list)
 983             (www-format-value-as-domain-list value without-tags))
 984            ((eq format 'string)
 985             (www-format-encode-string (format "%s" value) without-tags)
 986             )
 987            (t
 988             (www-format-value-default value without-tags)
 989             ))
 990           )
 991     (if (or without-tags
 992             without-edit
 993             (eq (plist-get props :mode) 'peek))
 994         ret
 995       (format "%s <a href=\"%s?char=%s&feature=%s&format=%s\"
 996 ><input type=\"submit\" value=\"edit\" /></a>"
 997               ret
 998               chise-wiki-edit-url
 999               uri-object uri-feature format))))
1000
1001 (defun www-format-eval-feature-value (object
1002                                       feature-name
1003                                       &optional format lang uri-object value
1004                                       without-tags without-edit)
1005   (unless value
1006     (setq value (www-get-feature-value object feature-name)))
1007   (unless format
1008     (setq format (www-feature-value-format feature-name)))
1009   (cond
1010    ((symbolp format)
1011     (www-format-apply-value
1012      object feature-name
1013      format nil value
1014      uri-object (www-uri-encode-feature-name feature-name)
1015      without-tags without-edit)
1016     )
1017    ((consp format)
1018     (cond ((null (cdr format))
1019            (setq format (car format))
1020            (www-format-apply-value
1021             object feature-name
1022             (car format) (nth 1 format) value
1023             uri-object (www-uri-encode-feature-name feature-name)
1024             without-tags without-edit)
1025            )
1026           (t
1027            (www-format-eval-list format object feature-name lang uri-object
1028                                  without-tags without-edit)
1029            )))))
1030
1031 (defun www-format-eval-unit (exp object feature-name
1032                                  &optional lang uri-object value
1033                                  without-tags without-edit)
1034   (unless value
1035     (setq value (www-get-feature-value object feature-name)))
1036   (unless uri-object
1037     (setq uri-object (www-uri-encode-char object)))
1038   (cond
1039    ((stringp exp) (www-format-encode-string exp))
1040    ((null exp) "")
1041    ((consp exp)
1042     (cond
1043      ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
1044                               S-exp string default))
1045       (let ((fn (plist-get (nth 1 exp) :feature))
1046             domain domain-fn ret)
1047         (when fn
1048           (when (stringp fn)
1049             (setq fn (intern fn)))
1050           (setq domain (char-feature-name-domain feature-name))
1051           (setq domain-fn (char-feature-name-at-domain fn domain))
1052           (if (setq ret (www-get-feature-value object domain-fn))
1053               (setq feature-name domain-fn
1054                     value ret)
1055             (setq feature-name fn
1056                   value (www-get-feature-value object fn)))
1057           (push feature-name chise-wiki-displayed-features)
1058           ))
1059       (if (eq (car exp) 'value)
1060           (www-format-eval-feature-value object feature-name
1061                                          (plist-get (nth 1 exp) :format)
1062                                          lang uri-object value
1063                                          without-tags without-edit)
1064         (www-format-apply-value
1065          object feature-name
1066          (car exp) (nth 1 exp) value
1067          uri-object (www-uri-encode-feature-name feature-name)
1068          without-tags without-edit))
1069       )
1070      ((eq (car exp) 'name)
1071       (let ((fn (plist-get (nth 1 exp) :feature))
1072             domain domain-fn)
1073         (when fn
1074           (setq domain (char-feature-name-domain feature-name))
1075           (when (stringp fn)
1076             (setq fn (intern fn)))
1077           (setq domain-fn (char-feature-name-at-domain fn domain))
1078           (setq feature-name domain-fn)))
1079       (if without-tags
1080           (www-format-feature-name feature-name lang)
1081         (format "<a href=\"%s\">%s</a>"
1082                 (www-uri-make-feature-name-url
1083                  (www-uri-encode-feature-name feature-name)
1084                  uri-object)
1085                 (www-format-feature-name feature-name lang))
1086         )
1087       )
1088      ((eq (car exp) 'name-url)
1089       (let ((fn (plist-get (nth 1 exp) :feature))
1090             domain domain-fn)
1091         (when fn
1092           (setq domain (char-feature-name-domain feature-name))
1093           (when (stringp fn)
1094             (setq fn (intern fn)))
1095           (setq domain-fn (char-feature-name-at-domain fn domain))
1096           (setq feature-name domain-fn)))
1097       (www-uri-make-feature-name-url
1098        (www-uri-encode-feature-name feature-name)
1099        uri-object)
1100       )
1101      ((eq (car exp) 'domain-name)
1102       (let ((domain (char-feature-name-domain feature-name)))
1103         (if domain
1104             (format "@%s" domain))))
1105      ((eq (car exp) 'prev-char)
1106       (if without-tags
1107           ""
1108         (let ((prev-char (find-previous-defined-code-point
1109                           feature-name value)))
1110           (if prev-char
1111               (format "\n<a href=\"%s?char=%s\">%s</a>"
1112                       chise-wiki-view-url
1113                       (www-uri-encode-char prev-char)
1114                       "<input type=\"submit\" value=\"-\" />"
1115                       ;; (www-format-encode-string
1116                       ;;  (char-to-string prev-char))
1117                       )
1118             "")))
1119       )
1120      ((eq (car exp) 'next-char)
1121       (if without-tags
1122           ""
1123         (let ((next-char (find-next-defined-code-point
1124                           feature-name value)))
1125           (if next-char
1126               (format "<a href=\"%s?char=%s\">%s</a>"
1127                       chise-wiki-view-url
1128                       (www-uri-encode-char next-char)
1129                       "<input type=\"submit\" value=\"+\" />"
1130                       ;; (www-format-encode-string
1131                       ;;  (char-to-string next-char))
1132                       )
1133             "")))
1134       )
1135      ((eq (car exp) 'link)
1136       (if without-tags
1137           (www-format-eval-list (nthcdr 2 exp)
1138                                 object feature-name lang uri-object
1139                                 without-tags without-edit)
1140         (format "<a
1141  href=\"%s\"
1142 >%s</a
1143 >"
1144                 (www-format-eval-list (plist-get (nth 1 exp) :ref)
1145                                       object feature-name lang uri-object
1146                                       'without-tags 'without-edit)
1147                 (www-format-eval-list (nthcdr 2 exp)
1148                                       object feature-name lang uri-object
1149                                       without-tags without-edit)))
1150       )
1151      (t
1152       (format "<%s
1153 >%s</%s
1154 >"
1155               (car exp)
1156               (www-format-eval-list (nthcdr 2 exp) object feature-name
1157                                     lang uri-object
1158                                     without-tags without-edit)
1159               (car exp)))))))
1160
1161 (defun www-format-eval-list (format-list object feature-name
1162                                          &optional lang uri-object
1163                                          without-tags without-edit)
1164   (if (consp format-list)
1165       (mapconcat
1166        (lambda (exp)
1167          (www-format-eval-unit exp object feature-name lang uri-object
1168                                nil without-tags without-edit))
1169        format-list "")
1170     (www-format-eval-unit format-list object feature-name lang uri-object
1171                           nil without-tags without-edit)))
1172
1173
1174 ;;; @ XML generator
1175 ;;;
1176
1177 (defun www-xml-format-props (props)
1178   (let ((dest "")
1179         key val)
1180     (while props
1181       (setq key (pop props)
1182             val (pop props))
1183       (if (symbolp key)
1184           (setq key (symbol-name key)))
1185       (if (eq (aref key 0) ?:)
1186           (setq key (substring key 1)))
1187       (setq dest
1188             (format "%s %s=\"%s\""
1189                     dest key
1190                     (www-format-encode-string
1191                      (format "%s" val) 'without-tags))))
1192     dest))
1193
1194 (defun www-xml-format-unit (format-unit)
1195   (let (name props children ret)
1196     (cond
1197      ((stringp format-unit)
1198       (mapconcat (lambda (c)
1199                    (cond
1200                     ((eq c ?&) "&amp;")
1201                     ;; ((eq c ?<) "&amp;lt;")
1202                     ;; ((eq c ?>) "&amp;gt;")
1203                     (t
1204                      (char-to-string c))))
1205                  (www-format-encode-string format-unit 'without-tags)
1206                  "")
1207       )
1208      ((consp format-unit)
1209       (setq name (car format-unit)
1210             props (nth 1 format-unit)
1211             children (nthcdr 2 format-unit))
1212       (when (eq name 'link)
1213         (setq ret (plist-get props :ref))
1214         (unless (stringp ret)
1215           (setq props (plist-remprop (copy-list props) :ref))
1216           (setq children
1217                 (cons (list* 'ref nil ret)
1218                       children))))
1219       (if children
1220           (format "<%s%s>%s</%s>"
1221                   name
1222                   (if props
1223                       (www-xml-format-props props)
1224                     "")
1225                   (www-xml-format-list children)
1226                   name)
1227         (format "<%s%s/>"
1228                 name (www-xml-format-props props)))
1229       )
1230      (t
1231       (format "%s" format-unit)))))
1232
1233 (defun www-xml-format-list (format-list)
1234   (if (atom format-list)
1235       (www-xml-format-unit format-list)
1236     (mapconcat #'www-xml-format-unit
1237                format-list "")))
1238
1239
1240 ;;; @ HTML generator
1241 ;;;
1242
1243 (defun www-html-display-text (text)
1244   (princ
1245    (with-temp-buffer
1246      (insert text)
1247      (goto-char (point-min))
1248      (while (search-forward "<" nil t)
1249        (replace-match "&lt;" nil t))
1250      (goto-char (point-min))
1251      (while (search-forward ">" nil t)
1252        (replace-match "&gt;" nil t))
1253      (goto-char (point-min))
1254      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
1255        (replace-match
1256         (format "<a href=\"%s\">%s</a>"
1257                 (match-string 2)
1258                 (match-string 1))
1259         nil t))
1260      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
1261      (goto-char (point-min))
1262      (while (search-forward "&GT-" nil t)
1263        (replace-match "&amp;GT-" nil t))
1264      (buffer-string))))
1265
1266 (defun www-html-display-paragraph (text)
1267   (princ "<p>")
1268   (www-html-display-text text)
1269   (princ "</p>\n"))
1270
1271
1272 ;;; @ for GlyphWiki
1273 ;;;
1274
1275 (defvar coded-charset-GlyphWiki-id-alist
1276   '((=ucs               "u"     4 x nil)
1277     (=ucs@JP            "u"     4 x nil)
1278     (=ucs@jis           "u"     4 x nil)
1279     (=ucs@gb            "u"     4 x "-g")
1280     (=ucs@cns           "u"     4 x "-t")
1281     (=ucs@ks            "u"     4 x "-k")
1282     (=ucs@iso           "u"     4 x "-u")
1283     (=ucs@unicode       "u"     4 x "-us")
1284     (=adobe-japan1-6    "aj1-"  5 d nil)
1285     (=gt                "gt-"   5 d nil)
1286     (=big5-cdp          "cdp-"  4 x nil)
1287     (=cbeta             "cb"    5 d nil)
1288     (=jis-x0208@1978/1pr "j78-" 4 x nil)
1289     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
1290     (=jis-x0208@1978    "j78-"  4 x nil)
1291     (=jis-x0208@1983    "j83-"  4 x nil)
1292     (=jis-x0208@1990    "j90-"  4 x nil)
1293     (=jis-x0212         "jsp-"  4 x nil)
1294     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
1295     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
1296     (=jis-x0213-2       "jx2-"  4 x nil)
1297     (=cns11643-1        "c1-"   4 x nil)
1298     (=cns11643-2        "c2-"   4 x nil)
1299     (=cns11643-3        "c3-"   4 x nil)
1300     (=cns11643-4        "c4-"   4 x nil)
1301     (=cns11643-5        "c5-"   4 x nil)
1302     (=cns11643-6        "c6-"   4 x nil)
1303     (=cns11643-7        "c7-"   4 x nil)
1304     (=daikanwa          "dkw-"  5 d nil)
1305     (=gt-k              "gt-k"  5 d nil)
1306     (=jef-china3        "jc3-"  4 x nil)
1307     (=big5              "b-"    4 x nil)
1308     (=ks-x1001          "k0-"   4 x nil)
1309     ))
1310
1311 (defun char-GlyphWiki-id (char)
1312   (let ((rest coded-charset-GlyphWiki-id-alist)
1313         spec ret code)
1314     (while (and rest
1315                 (setq spec (pop rest))
1316                 (null (setq ret (char-feature char (car spec))))))
1317     (when ret
1318       (or
1319        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
1320             (cond
1321              ((and (or (encode-char char '=jis-x0208@1990)
1322                        (encode-char char '=jis-x0212)
1323                        (encode-char char '=jis-x0213-1))
1324                    (setq code (encode-char char '=ucs@jis)))
1325               (format "u%04x" code)
1326               )
1327              ((and (or (encode-char char '=gb2312)
1328                        (encode-char char '=gb12345))
1329                    (setq code (encode-char char '=ucs@gb)))
1330               (format "u%04x-g" code)
1331               )
1332              ((and (or (encode-char char '=cns11643-1)
1333                        (encode-char char '=cns11643-2)
1334                        (encode-char char '=cns11643-3)
1335                        (encode-char char '=cns11643-4)
1336                        (encode-char char '=cns11643-5)
1337                        (encode-char char '=cns11643-6)
1338                        (encode-char char '=cns11643-7))
1339                    (setq code (encode-char char '=ucs@cns)))
1340               (format "u%04x-t" code)
1341               )
1342              ((and (encode-char char '=ks-x1001)
1343                    (setq code (encode-char char '=ucs@ks)))
1344               (format "u%04x-k" code)
1345               )))
1346        (format (format "%s%%0%d%s%s"
1347                        (nth 1 spec)
1348                        (nth 2 spec)
1349                        (nth 3 spec)
1350                        (or (nth 4 spec) ""))
1351                ret)))))
1352
1353
1354 ;;; @ End.
1355 ;;;
1356
1357 (provide 'cwiki-common)
1358
1359 ;;; cwiki-common.el ends here