cwiki-common.el

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