cwiki-common.el

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