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