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