cwiki-format.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'cwiki-common)
   3 (require 'est-xml)
   4
   5 ;;; @ Feature value presentation
   6 ;;;
   7
   8 (defun www-format-value-as-kuten (value)
   9   (format "%02d-%02d"
  10           (- (lsh value -8) 32)
  11           (- (logand value 255) 32)))
  12
  13 (defun www-format-value-default (value &optional without-tags)
  14   (if (listp value)
  15       (mapconcat
  16        (lambda (unit)
  17          (www-format-encode-string
  18           (format "%S" unit)
  19           without-tags))
  20        value " ")
  21     (www-format-encode-string (format "%S" value) without-tags)))
  22
  23 (defun www-format-value-as-char-list (value &optional without-tags)
  24   (if (listp value)
  25       (mapconcat
  26        (if without-tags
  27            (lambda (unit)
  28              (www-format-encode-string
  29               (format (if (characterp unit)
  30                           "%c"
  31                         "%s")
  32                       unit)
  33               'without-tags))
  34          (let (genre-o name-f ret)
  35            (lambda (unit)
  36              (if (characterp unit)
  37                  (format "<a href=\"%s?char=%s\">%s</a>"
  38                          chise-wiki-view-url
  39                          (www-uri-encode-object unit)
  40                          (www-format-encode-string (char-to-string unit)))
  41                (format "<a href=\"%s?%s=%s\">%s</a>"
  42                        chise-wiki-view-url
  43                        (concord-object-genre unit)
  44                        (concord-object-id unit)
  45                        (cond
  46                         ((setq ret
  47                                (www-get-feature-value
  48                                 unit
  49                                 (setq name-f
  50                                       (if (setq genre-o
  51                                                 (concord-decode-object
  52                                                  '=id
  53                                                  (concord-object-genre unit)
  54                                                  'genre))
  55                                           (www-get-feature-value
  56                                            genre-o
  57                                            'object-representation-format)
  58                                         'name))))
  59                          (www-format-eval-feature-value
  60                           unit name-f nil nil nil ret
  61                           'without-tags 'without-edit)
  62                          )
  63                         (t
  64                          (www-format-encode-string
  65                           (format "%S" unit))
  66                          ))
  67                        unit)))))
  68        value " ")
  69     (www-format-encode-string (format "%s" value) without-tags)))
  70
  71 (defun www-format-value-as-domain-list (value &optional without-tags)
  72   (let (name source0 source num dest rest unit start end ddest)
  73     (if (listp value)
  74         (if without-tags
  75             (mapconcat
  76              (lambda (unit)
  77                (format "%s" unit))
  78              value " ")
  79           (setq rest value)
  80           (while rest
  81             (setq unit (pop rest))
  82             (if (symbolp unit)
  83                 (setq name (symbol-name unit)))
  84             (setq dest
  85                   (concat
  86                    dest
  87                    (cond
  88                     ((string-match "^zob1968=" name)
  89                      (setq source (intern (substring name 0 (match-end 0)))
  90                            num (substring name (match-end 0)))
  91                      (if (string-match "^\\([0-9]+\\)-\\([0-9]+\\)$" num)
  92                          (setq start (string-to-number
  93                                       (match-string 1 num))
  94                                end (string-to-number
  95                                     (match-string 2 num)))
  96                        (setq start (string-to-number num)
  97                              end start))
  98                      (setq ddest
  99                            (if (eq source source0)
 100                                (format
 101                                 ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
 102                                 start start)
 103                              (setq source0 source)
 104                              (format
 105                               " <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>"
 106                               (www-format-encode-string "\u4EAC\e$BBg?M\e(B\u6587\e$B8&9C\e(B\u9AA8")
 107                               start start)))
 108                      (setq start (1+ start))
 109                      (while (<= start end)
 110                        (setq ddest
 111                              (concat
 112                               ddest
 113                               (format
 114                                ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
 115                                start start)))
 116                        (setq start (1+ start)))
 117                      ddest)
 118                     (t
 119                      (setq source unit)
 120                      (if (eq source source0)
 121                          ""
 122                        (setq source0 source)
 123                        (concat " " name))
 124                      )))))
 125           dest)
 126       (www-format-encode-string (format "%s" value) without-tags))))
 127
 128 (defun www-format-value-as-ids (value &optional without-tags)
 129   (if (listp value)
 130       (mapconcat
 131        (if without-tags
 132            (lambda (unit)
 133              (www-format-encode-string
 134               (format (if (characterp unit)
 135                           "%c"
 136                         "%s")
 137                       unit)
 138               'without-tags))
 139          (lambda (unit)
 140            (if (characterp unit)
 141                (format "<a href=\"%s?char=%s\">%s</a>"
 142                        chise-wiki-view-url
 143                        (www-uri-encode-object unit)
 144                        (www-format-encode-string (char-to-string unit)))
 145              (www-format-encode-string (format "%s" unit)))))
 146        (ideographic-structure-to-ids value) " ")
 147     (www-format-encode-string (format "%s" value) without-tags)))
 148
 149 (defun www-format-value-as-S-exp (value &optional without-tags)
 150   (www-format-encode-string (format "%S" value) without-tags))
 151
 152 (defun www-format-value-as-HEX (value)
 153   (if (integerp value)
 154       (format "%X" value)
 155     (www-format-value-as-S-exp value)))
 156
 157 (defun www-format-value-as-CCS-default (value)
 158   (if (integerp value)
 159       (format "0x%s (%d)"
 160               (www-format-value-as-HEX value)
 161               value)
 162     (www-format-value-as-S-exp value)))
 163
 164 (defun www-format-value-as-CCS-94x94 (value)
 165   (if (integerp value)
 166       (format "0x%s [%s] (%d)"
 167               (www-format-value-as-HEX value)
 168               (www-format-value-as-kuten value)
 169               value)
 170     (www-format-value-as-S-exp value)))
 171
 172 (defun www-format-value-as-kangxi-radical (value)
 173   (if (and (integerp value)
 174            (<= 0 value)
 175            (<= value 214))
 176       (www-format-encode-string
 177        (format "%c" (ideographic-radical value)))
 178     (www-format-value-as-S-exp value)))
 179
 180 (defun www-format-value (object feature-name
 181                                 &optional value format
 182                                 without-tags without-edit)
 183   (unless value
 184     (setq value (www-get-feature-value object feature-name)))
 185   (www-format-apply-value object feature-name
 186                           format nil value nil nil
 187                           without-tags without-edit)
 188   )
 189
 190
 191 ;;; @ format evaluator
 192 ;;;
 193
 194 (defun www-format-props-to-string (props &optional format)
 195   (unless format
 196     (setq format (plist-get props :format)))
 197   (concat "%"
 198           (plist-get props :flag)
 199           ;; (if (plist-get props :zero-padding)
 200           ;;     "0")
 201           (if (plist-get props :len)
 202               (format "0%d"
 203                       (let ((ret (plist-get props :len)))
 204                         (if (stringp ret)
 205                             (string-to-int ret)
 206                           ret))))
 207           (cond
 208            ((eq format 'decimal) "d")
 209            ((eq format 'hex) "x")
 210            ((eq format 'HEX) "X")
 211            ((eq format 'S-exp) "S")
 212            (t "s"))))
 213
 214 (defun www-format-apply-value (object feature-name
 215                                       format props value
 216                                       &optional uri-object uri-feature
 217                                       without-tags without-edit)
 218   (let (ret)
 219     (setq ret
 220           (cond
 221            ((memq format '(decimal hex HEX))
 222             (if (integerp value)
 223                 (format (www-format-props-to-string props format)
 224                         value)
 225               (www-format-encode-string
 226                (format "%s" value)
 227                without-tags))
 228             )
 229            ((eq format 'wiki-text)
 230             (if without-tags
 231                 (www-xml-format-list value)
 232               (www-format-eval-list value object feature-name nil uri-object
 233                                     without-tags without-edit))
 234             )
 235            ((eq format 'S-exp)
 236             (www-format-encode-string
 237              (format (www-format-props-to-string props format)
 238                      value)
 239              without-tags))
 240            ((eq format 'ku-ten)
 241             (www-format-value-as-kuten value))
 242            ((eq format 'kangxi-radical)
 243             (www-format-value-as-kangxi-radical value))
 244            ((eq format 'space-separated-char-list)
 245             (www-format-value-as-char-list value without-tags))
 246            ((eq format 'space-separated-ids)
 247             (www-format-value-as-ids value without-tags))
 248            ((eq format 'space-separated-domain-list)
 249             (www-format-value-as-domain-list value without-tags))
 250            ((eq format 'string)
 251             (www-format-encode-string (format "%s" value) without-tags)
 252             )
 253            (t
 254             (www-format-value-default value without-tags)
 255             ))
 256           )
 257     (if (or without-tags
 258             without-edit
 259             (eq (plist-get props :mode) 'peek))
 260         ret
 261       (format "%s <a href=\"%s?%s=%s&feature=%s&format=%s\"
 262 ><input type=\"submit\" value=\"edit\" /></a>"
 263               ret
 264               chise-wiki-edit-url
 265               (est-object-genre object)
 266               uri-object uri-feature format))))
 267
 268 (defun www-format-eval-feature-value (object
 269                                       feature-name
 270                                       &optional format lang uri-object value
 271                                       without-tags without-edit)
 272   (unless value
 273     (setq value (www-get-feature-value object feature-name)))
 274   (unless format
 275     (setq format (www-feature-value-format feature-name)))
 276   (cond
 277    ((symbolp format)
 278     (www-format-apply-value
 279      object feature-name
 280      format nil value
 281      uri-object (www-uri-encode-feature-name feature-name)
 282      without-tags without-edit)
 283     )
 284    ((consp format)
 285     (cond ((null (cdr format))
 286            (setq format (car format))
 287            (www-format-apply-value
 288             object feature-name
 289             (car format) (nth 1 format) value
 290             uri-object (www-uri-encode-feature-name feature-name)
 291             without-tags without-edit)
 292            )
 293           (t
 294            (www-format-eval-list format object feature-name lang uri-object
 295                                  without-tags without-edit)
 296            )))))
 297
 298 (defun www-format-eval-unit (exp object feature-name
 299                                  &optional lang uri-object value
 300                                  without-tags without-edit)
 301   (unless value
 302     (setq value (www-get-feature-value object feature-name)))
 303   (unless uri-object
 304     (setq uri-object (www-uri-encode-object object)))
 305   (cond
 306    ((stringp exp) (www-format-encode-string exp))
 307    ((null exp) "")
 308    ((consp exp)
 309     (cond
 310      ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
 311                               S-exp string default))
 312       (let ((fn (plist-get (nth 1 exp) :feature))
 313             domain domain-fn ret)
 314         (when fn
 315           (when (stringp fn)
 316             (setq fn (intern fn)))
 317           (setq domain (char-feature-name-domain feature-name))
 318           (setq domain-fn (char-feature-name-at-domain fn domain))
 319           (if (setq ret (www-get-feature-value object domain-fn))
 320               (setq feature-name domain-fn
 321                     value ret)
 322             (setq feature-name fn
 323                   value (www-get-feature-value object fn)))
 324           (push feature-name chise-wiki-displayed-features)
 325           ))
 326       (if (eq (car exp) 'value)
 327           (www-format-eval-feature-value object feature-name
 328                                          (plist-get (nth 1 exp) :format)
 329                                          lang uri-object value
 330                                          without-tags without-edit)
 331         (www-format-apply-value
 332          object feature-name
 333          (car exp) (nth 1 exp) value
 334          uri-object (www-uri-encode-feature-name feature-name)
 335          without-tags without-edit))
 336       )
 337      ((eq (car exp) 'name)
 338       (let ((fn (plist-get (nth 1 exp) :feature))
 339             domain domain-fn)
 340         (when fn
 341           (setq domain (char-feature-name-domain feature-name))
 342           (when (stringp fn)
 343             (setq fn (intern fn)))
 344           (setq domain-fn (char-feature-name-at-domain fn domain))
 345           (setq feature-name domain-fn)))
 346       (if without-tags
 347           (www-format-feature-name feature-name lang)
 348         (format "<a href=\"%s\">%s</a>"
 349                 (www-uri-make-feature-name-url
 350                  (www-uri-encode-feature-name feature-name)
 351                  uri-object)
 352                 (www-format-feature-name feature-name lang))
 353         )
 354       )
 355      ((eq (car exp) 'name-url)
 356       (let ((fn (plist-get (nth 1 exp) :feature))
 357             domain domain-fn)
 358         (when fn
 359           (setq domain (char-feature-name-domain feature-name))
 360           (when (stringp fn)
 361             (setq fn (intern fn)))
 362           (setq domain-fn (char-feature-name-at-domain fn domain))
 363           (setq feature-name domain-fn)))
 364       (www-uri-make-feature-name-url
 365        (www-uri-encode-feature-name feature-name)
 366        uri-object)
 367       )
 368      ((eq (car exp) 'domain-name)
 369       (let ((domain (char-feature-name-domain feature-name)))
 370         (if domain
 371             (format "@%s" domain))))
 372      ((eq (car exp) 'prev-char)
 373       (if without-tags
 374           ""
 375         (let ((prev-char (find-previous-defined-code-point
 376                           feature-name value)))
 377           (if prev-char
 378               (format "\n<a href=\"%s?char=%s\">%s</a>"
 379                       chise-wiki-view-url
 380                       (www-uri-encode-object prev-char)
 381                       "<input type=\"submit\" value=\"-\" />"
 382                       ;; (www-format-encode-string
 383                       ;;  (char-to-string prev-char))
 384                       )
 385             "")))
 386       )
 387      ((eq (car exp) 'next-char)
 388       (if without-tags
 389           ""
 390         (let ((next-char (find-next-defined-code-point
 391                           feature-name value)))
 392           (if next-char
 393               (format "<a href=\"%s?char=%s\">%s</a>"
 394                       chise-wiki-view-url
 395                       (www-uri-encode-object next-char)
 396                       "<input type=\"submit\" value=\"+\" />"
 397                       ;; (www-format-encode-string
 398                       ;;  (char-to-string next-char))
 399                       )
 400             "")))
 401       )
 402      ((eq (car exp) 'link)
 403       (if without-tags
 404           (www-format-eval-list (nthcdr 2 exp)
 405                                 object feature-name lang uri-object
 406                                 without-tags without-edit)
 407         (format "<a
 408  href=\"%s\"
 409 >%s</a
 410 >"
 411                 (www-format-eval-list (plist-get (nth 1 exp) :ref)
 412                                       object feature-name lang uri-object
 413                                       'without-tags 'without-edit)
 414                 (www-format-eval-list (nthcdr 2 exp)
 415                                       object feature-name lang uri-object
 416                                       without-tags without-edit)))
 417       )
 418      (t
 419       (format "<%s
 420 >%s</%s
 421 >"
 422               (car exp)
 423               (www-format-eval-list (nthcdr 2 exp) object feature-name
 424                                     lang uri-object
 425                                     without-tags without-edit)
 426               (car exp)))))))
 427
 428 (defun www-format-eval-list (format-list object feature-name
 429                                          &optional lang uri-object
 430                                          without-tags without-edit)
 431   (if (consp format-list)
 432       (mapconcat
 433        (lambda (exp)
 434          (www-format-eval-unit exp object feature-name lang uri-object
 435                                nil without-tags without-edit))
 436        format-list "")
 437     (www-format-eval-unit format-list object feature-name lang uri-object
 438                           nil without-tags without-edit)))
 439
 440
 441 ;;; @ End.
 442 ;;;
 443
 444 (provide 'cwiki-format)
 445
 446 ;;; cwiki-format.el ends here