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