cwiki-common.el

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