cwiki-common.el

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