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