est-eval.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'cwiki-common)
   3
   4 (defvar est-eval-list-feature-items-limit 20)
   5
   6 (defun ruimoku-format-volume (spec value year lang)
   7   (when (stringp spec)
   8     (setq spec (car (read-from-string spec))))
   9   (cond ((eq spec 'YY) (if (eq lang 'cjk)
  10                                  (format "%d年" year)
  11                                (format "%d" year)))
  12         ((eq spec 00) value)
  13         ((eq spec 01) (concat value "期"))
  14         ((eq spec 02) (concat value "巻"))
  15         ((eq spec 03) (concat value "号"))
  16         ((eq spec 04) (concat value "編"))
  17         ((eq spec 05) (concat value "&HD-JA-4A53;"))
  18         ((eq spec 06) (concat value "集"))
  19         ((eq spec 07) (concat value "輯"))
  20         ((eq spec 08) (concat value "部"))
  21         ((eq spec 09) (concat value "部分"))
  22         ((eq spec 10) (concat value "冊"))
  23         ((eq spec 11) (concat value "分冊"))
  24         ((eq spec 12) (concat value "次"))
  25         ((eq spec 13) (concat value "月号"))
  26         ((eq spec 14) (concat value "特集号"))
  27         ((eq spec 15) (concat value "本"))
  28         ((eq spec 16) (concat value "分"))
  29         ((eq spec 51) (concat "Vol." value))
  30         ((eq spec 52) (concat "No." value))
  31         ((eq spec 53) (concat "Part " value))
  32         ((eq spec 54) (concat "Issue " value))
  33         ((eq spec 55) (concat "Tome " value))
  34         ((eq spec 56) (concat "Tomo " value))
  35         ((eq spec 57) (concat "Tomus " value))
  36         ((eq spec 58) (concat "Fasc." value))
  37         ((eq spec 59) (concat "Livre " value))
  38         ((eq spec 60) (concat "Année " value))
  39         ((eq spec 61) (concat "Bd." value))
  40         ((eq spec 62) (concat "Heft " value))
  41         ((eq spec 63) (concat "Nr." value))
  42         ((eq spec 64) (concat "Jahrg." value))
  43         ((eq spec 65) (concat "Jaarg." value))
  44         ((eq spec 66) (concat "Trimestre" value))
  45         (t "")
  46         ))
  47
  48
  49 ;;; @ Feature value presentation
  50 ;;;
  51
  52 (defun est-eval-value-as-S-exp (value)
  53   (list 'S-exp nil (format "%S" value)))
  54
  55 (defun est-eval-value-default (value)
  56   (if (listp value)
  57       (if (eq (car value) 'omitted)
  58           value
  59         (list* 'list
  60                '(:separator " ")
  61                (mapcar
  62                 (lambda (unit)
  63                   (format "%S" unit))
  64                 value)))
  65     (est-eval-value-as-S-exp value)))
  66
  67 (defun est-eval-value-as-image-resource (value)
  68   (let ((name (concord-object-get value 'name)))
  69     (if (concord-object-get value 'image-offset-x)
  70         (list 'img (list* :src (or (concord-object-get value '=location@iiif)
  71                                    (concord-object-get value '=location))
  72                           (if name
  73                               (list :alt name))))
  74       name)))
  75
  76 ;; (defun est-journal-volume-object-get-volume-format (spec feature)
  77 ;;   (when (integerp spec)
  78 ;;     (setq spec (format "%02d" spec)))
  79 ;;   (cond ((string= spec "YY") `((decimal (:feature
  80 ;;                                          ->published/date*year)) "年"))
  81 ;;         ((string= spec "00") `((decimal (:feature ,feature))))
  82 ;;         ((string= spec "01") `((decimal (:feature ,feature)) "期"))
  83 ;;         ((string= spec "02") `((decimal (:feature ,feature)) "巻"))
  84 ;;         ((string= spec "03") `((decimal (:feature ,feature)) "号"))
  85 ;;         ((string= spec "04") `((decimal (:feature ,feature)) "&AJ1-03620;"))
  86 ;;         ((string= spec "05") `((decimal (:feature ,feature)) "&HD-JA-4A53;"))
  87 ;;         ((string= spec "06") `((decimal (:feature ,feature)) "集"))
  88 ;;         ((string= spec "07") `((decimal (:feature ,feature)) "輯"))
  89 ;;         ((string= spec "08") `((decimal (:feature ,feature)) "部"))
  90 ;;         ((string= spec "09") `((decimal (:feature ,feature)) "部分"))
  91 ;;         ((string= spec "10") `((decimal (:feature ,feature)) "冊"))
  92 ;;         ((string= spec "11") `((decimal (:feature ,feature)) "分冊"))
  93 ;;         ((string= spec "12") `((decimal (:feature ,feature)) "次"))
  94 ;;         ((string= spec "13") `((decimal (:feature ,feature)) "月号"))
  95 ;;         ((string= spec "14") `((decimal (:feature ,feature)) "特集号"))
  96 ;;         ((string= spec "15") `((decimal (:feature ,feature)) "本"))
  97 ;;         ((string= spec "16") `((decimal (:feature ,feature)) "分"))
  98 ;;         ((string= spec "51") `("Vol." ((decimal (:feature ,feature)))))
  99 ;;         ((string= spec "52") `("No." ((decimal (:feature ,feature)))))
 100 ;;         ((string= spec "53") `("Part " ((decimal (:feature ,feature)))))
 101 ;;         ((string= spec "54") `("Issue " ((decimal (:feature ,feature)))))
 102 ;;         ((string= spec "55") `("Tome " ((decimal (:feature ,feature)))))
 103 ;;         ((string= spec "56") `("Tomo " ((decimal (:feature ,feature)))))
 104 ;;         ((string= spec "57") `("Tomus " ((decimal (:feature ,feature)))))
 105 ;;         ((string= spec "58") `("Fasc." ((decimal (:feature ,feature)))))
 106 ;;         ((string= spec "59") `("Livre " ((decimal (:feature ,feature)))))
 107 ;;         ((string= spec "60") `("Année " ((decimal (:feature ,feature)))))
 108 ;;         ((string= spec "61") `("Bd." ((decimal (:feature ,feature)))))
 109 ;;         ((string= spec "62") `("Heft " ((decimal (:feature ,feature)))))
 110 ;;         ((string= spec "63") `("Nr." ((decimal (:feature ,feature)))))
 111 ;;         ((string= spec "64") `("Jahrg." ((decimal (:feature ,feature)))))
 112 ;;         ((string= spec "65") `("Jaarg." ((decimal (:feature ,feature)))))
 113 ;;         ((string= spec "66") `("Trimestre" ((decimal (:feature ,feature)))))
 114 ;;         (t nil)
 115 ;;         ))
 116
 117 (defun est-eval-value-as-journal-volume (value &optional short)
 118   (let ((journal (car (or (concord-object-get value '<-journal/volume)
 119                           (concord-object-get value '<-volume))))
 120         (vol-name (concord-object-get value '<-journal/volume*name))
 121         volume-type number-type
 122         year
 123         dest ret title subtitle)
 124     (cond
 125      (journal
 126       (if vol-name
 127           (setq dest
 128                 (list
 129                  (list 'object (list :object value)
 130                        vol-name)))
 131         (setq volume-type (concord-object-get journal 'volume/type/code)
 132               number-type (concord-object-get journal 'number/type/code))
 133         (setq year (or (concord-object-get value '->published/date*year)
 134                        (concord-object-get
 135                         (car (concord-object-get value 'date)) 'year)))
 136         (setq dest
 137               (list
 138                (list 'object
 139                      (list :object value)
 140                      (ruimoku-format-volume
 141                       volume-type
 142                       (or (concord-object-get value '<-journal/volume*volume)
 143                           (concord-object-get value '<-volume*volume))
 144                       year 'cjk)
 145                      (ruimoku-format-volume
 146                       number-type
 147                       (or (concord-object-get value '<-journal/volume*number)
 148                           (concord-object-get value '<-volume*number))
 149                       year 'cjk))))
 150         )
 151       (unless short
 152         (if (setq ret (est-eval-value-as-object journal))
 153             (setq dest
 154                   (list* ret " " dest))))
 155       (list* 'list '(:subtype sequence :separator "") dest)
 156       )
 157      ((setq title (concord-object-get value 'title))
 158       (setq subtitle (concord-object-get value 'title/subtitle))
 159       (list* 'object
 160              (list :object value)
 161              (if (eq (concord-object-get value 'writing-system) 'cjk)
 162                  (list
 163                   "「"
 164                   (list 'object (list :object value)
 165                         (if subtitle
 166                             (concat title " — " subtitle)
 167                           title))
 168                   "」")
 169                (list
 170                 " ‘"
 171                 (list 'object (list :object value)
 172                       (if subtitle
 173                           (concat title " — " subtitle)
 174                         title))
 175                 "’")))
 176       )
 177      (t
 178       (est-eval-value-default value)
 179       ))
 180     ;; (concat (concord-object-get journal 'name)
 181     ;;         " "
 182     ;;         (ruimoku-format-volume
 183     ;;          volume-type
 184     ;;          (or (concord-object-get value '<-journal/volume*volume)
 185     ;;              (concord-object-get value '<-volume*volume))
 186     ;;          year 'cjk)
 187     ;;         (ruimoku-format-volume
 188     ;;          number-type
 189     ;;          (or (concord-object-get value '<-journal/volume*number)
 190     ;;              (concord-object-get value '<-volume*number))
 191     ;;          year 'cjk))
 192     ))
 193
 194 (defun est-eval-value-as-article (value)
 195   (let ((journal-volume (car (concord-object-get value '<-article)))
 196         (page (concord-object-get value 'page))
 197         date ret dest)
 198     (when journal-volume
 199       (setq date (car (concord-object-get journal-volume 'date)))
 200       (if (and date
 201                (setq ret (est-eval-value-as-object date)))
 202           (setq dest (list ", " ret))))
 203     (if page
 204         (setq dest (list* ", pp." page dest)))
 205     (when (and journal-volume
 206                (setq ret (est-eval-value-as-journal-volume journal-volume)))
 207       (setq dest (cons ret dest)))
 208     (if (setq ret (est-eval-value-as-book value))
 209         (setq dest (list* ret " " dest)))
 210     (list* 'list '(:subtype sequence :separator "") dest))
 211   ;; (let ((creators (concord-object-get value '->creator))
 212   ;;       (title (concord-object-get value 'title))
 213   ;;       creator-name creator-role)
 214   ;;   (concat
 215   ;;    (mapconcat
 216   ;;     (lambda (creator)
 217   ;;       (setq creator-name
 218   ;;             (concord-object-get
 219   ;;              (car (concord-object-get creator '->creator/name))
 220   ;;              '=name))
 221   ;;       (setq creator-role
 222   ;;             (or (concord-object-get creator 'role*name)
 223   ;;                 (format "(%s)"
 224   ;;                         (concord-object-get creator 'role*type))))
 225   ;;       (concat creator-name " " creator-role))
 226   ;;     creators ", ")
 227   ;;    (if (eq (concord-object-get value 'writing-system) 'cjk)
 228   ;;        (concat  "「" title "」")
 229   ;;      (concat " ‘" title "’"))))
 230   )
 231
 232 (defun est-eval-value-as-book (value)
 233   (let ((creators (concord-object-get value '->creator))
 234         (title (concord-object-get value 'title))
 235         (subtitle (concord-object-get value 'title/subtitle))
 236         (series (concord-object-get value 'series))
 237         (publisher (car (concord-object-get value 'publisher)))
 238         (date (car (concord-object-get value 'date)))
 239         ;; creator-name creator-role
 240         dest ret)
 241     (if (and date
 242              (setq ret (est-eval-value-as-object date)))
 243         (setq dest (list ", " ret)))
 244     (if (and publisher
 245              (setq ret (est-eval-value-as-object publisher)))
 246         (setq dest (list* " " ret dest)))
 247     (if series
 248         (setq dest (list* series "," dest)))
 249     (setq dest
 250           (if title
 251               (if (eq (concord-object-get value 'writing-system) 'cjk)
 252                   (list*
 253                    "「"
 254                  (list 'object (list :object value)
 255                        (if subtitle
 256                            (concat title " — " subtitle)
 257                          title))
 258                  "」" dest)
 259               (list*
 260                " ‘"
 261                (list 'object (list :object value)
 262                      (if subtitle
 263                          (concat title " — " subtitle)
 264                        title))
 265                "’" dest))
 266             (list* " "
 267                    (list 'object (list :object value)
 268                          "(review)")
 269                    dest)))
 270     (when (and creators
 271                (setq ret (est-eval-value-as-creators-names creators)))
 272       (setq dest (cons ret dest)))
 273     (list* 'list '(:subtype sequence :separator "") dest)
 274     ;; (concat
 275     ;;  (mapconcat
 276     ;;   (lambda (creator)
 277     ;;     (setq creator-name
 278     ;;           (concord-object-get
 279     ;;            (car (concord-object-get creator '->creator/name))
 280     ;;            '=name))
 281     ;;     (setq creator-role
 282     ;;           (or (concord-object-get creator 'role*name)
 283     ;;               (format "(%s)"
 284     ;;                       (concord-object-get creator 'role*type))))
 285     ;;     (concat creator-name " " creator-role))
 286     ;;   creators ", ")
 287     ;;  (if (eq (concord-object-get value 'writing-system) 'cjk)
 288     ;;      (concat  "「" title
 289     ;;               (if subtitle
 290     ;;                   (concat " — " subtitle))
 291     ;;               "」")
 292     ;;    (concat " ‘" title
 293     ;;            (if subtitle
 294     ;;                (concat " — " subtitle))
 295     ;;            "’"))
 296     ;;  (if series
 297     ;;      (concat " " series))
 298     ;;  (if publisher
 299     ;;      (concat ", "
 300     ;;              (concord-object-get
 301     ;;               (car (concord-object-get
 302     ;;                     publisher '->publisher/name))
 303     ;;               '=name)))
 304     ;;  (if date
 305     ;;      (concat ", " (concord-object-get date 'name)))))
 306     ))
 307
 308 ;; (defun est-eval-creator (value)
 309 ;;   (est-eval-list
 310 ;;    '((value (:feature ->name))
 311 ;;      (string (:feature role*name)))
 312 ;;    value nil))
 313
 314 (defun est-eval-value-as-object (value)
 315   (if (or (characterp value)
 316           (concord-object-p value))
 317       (list 'object (list :object value)
 318             (if (characterp value)
 319                 (char-to-string value)
 320               (let ((genre (concord-object-genre value))
 321                     genre-o
 322                     format)
 323                 (cond
 324                  ((eq genre 'journal-volume@ruimoku)
 325                   ;; (est-eval-list
 326                   ;;  (est-journal-volume-get-object-format value)
 327                   ;;  value nil)
 328                   (est-eval-value-as-journal-volume value)
 329                   )
 330                  ((eq genre 'article@ruimoku)
 331                   (est-eval-value-as-article value)
 332                   )
 333                  ((eq genre 'book@ruimoku)
 334                   (est-eval-value-as-book value)
 335                   )
 336                  ;; ((eq genre 'creator@ruimoku)
 337                  ;;  (est-eval-creator value)
 338                  ;;  )
 339                  ((eq genre 'image-resource)
 340                   (est-eval-value-as-image-resource value)
 341                   )
 342                  (t
 343                   (setq genre-o (concord-decode-object '=id genre 'genre))
 344                   (or (and genre-o
 345                            (setq format
 346                                  (concord-object-get
 347                                   genre-o 'object-representative-format))
 348                            (est-eval-list format value nil))
 349                       (www-get-feature-value
 350                        value
 351                        (or (and genre-o
 352                                 (www-get-feature-value
 353                                  genre-o 'object-representative-feature))
 354                            'name))
 355                       (www-get-feature-value value '=name)
 356                       (est-eval-value-default value))
 357                   ))
 358                 )))
 359     (est-eval-value-default value)))
 360
 361 (defun est-eval-value-as-character (value)
 362   (let (ret)
 363   (if (and (concord-object-p value)
 364            (setq ret (concord-object-get value 'character)))
 365       (list 'object (list :object value)
 366             (mapconcat #'char-to-string ret ""))
 367     (est-eval-value-as-object value))))
 368
 369 (defun est-eval-value-as-HEX (value)
 370   (if (integerp value)
 371       (list 'HEX nil (format "%X" value))
 372     (est-eval-value-as-S-exp value)))
 373
 374 (defun est-eval-value-as-kuten (value)
 375   (if (integerp value)
 376       (list 'ku-ten
 377             nil
 378             (format "%02d-%02d"
 379                     (- (lsh value -8) 32)
 380                     (- (logand value 255) 32)))
 381     (est-eval-value-as-S-exp value)))
 382
 383 (defun est-eval-value-as-kangxi-radical (value)
 384   (if (and (integerp value)
 385            (<= 0 value)
 386            (<= value 214))
 387       (list 'kangxi-radical
 388             nil
 389             (format "%c" (ideographic-radical value)))
 390     (est-eval-value-as-S-exp value)))
 391
 392 (defun est-eval-value-as-object-list (value &optional separator subtype)
 393   (if (and (listp value)
 394            (listp (cdr value)))
 395       (condition-case nil
 396           (let (props)
 397             (if separator
 398                 (setq props (list :separator separator)))
 399             (if subtype
 400                 (setq props (list* :subtype subtype props)))
 401             (list* 'list props
 402                    (mapcar #'est-eval-value-as-object value)))
 403         (error (format "%s" value)))
 404     (format "%s" value)))
 405
 406 (defun est-eval-value-as-char-list (value &optional separator subtype)
 407   (if (and (listp value)
 408            (listp (cdr value)))
 409       (condition-case nil
 410           (let (props)
 411             (if separator
 412                 (setq props (list :separator separator)))
 413             (if subtype
 414                 (setq props (list* :subtype subtype props)))
 415             (list* 'list props
 416                    (mapcar #'est-eval-value-as-character value)))
 417         (error (format "%s" value)))
 418     (format "%s" value)))
 419
 420 (defun est-eval-value-as-composition-list (value &optional separator subtype)
 421   (if (and (listp value)
 422            (listp (cdr value)))
 423       (condition-case nil
 424           (let (props)
 425             (if separator
 426                 (setq props (list :separator separator)))
 427             (if subtype
 428                 (setq props (list* :subtype subtype props)))
 429             (list* 'list props
 430                    (mapcar
 431                     (lambda (cell)
 432                       (list 'list nil
 433                             "+ "
 434                             (list 'object (list :object (car cell))
 435                                   (format "U+%04X" (car cell)))
 436                             " : "
 437                             (est-eval-value-as-object (cdr cell))))
 438                     (sort value
 439                           (lambda (a b)
 440                             (< (car a)(car b)))))))
 441         (error (format "%s" value)))
 442     (format "%s" value)))
 443
 444 (defun est-eval-value-as-decomposition-list (value)
 445   (if (and (listp value)
 446            (listp (cdr value)))
 447       (condition-case nil
 448           (let (props)
 449             (list* 'list props
 450                    (mapconcat #'char-to-string value "")
 451                    (list
 452                     " ("
 453                     (list* 'list '(:separator " + ")
 454                            (mapcar
 455                             (lambda (chr)
 456                               (list 'object (list :object chr)
 457                                     (format "U+%04X" chr)))
 458                             value))
 459                     ")")))
 460         (error (format "%s" value)))
 461     (format "%s" value)))
 462
 463 ;; (defun est-eval-value-as-ids (value)
 464 ;;   (if (listp value)
 465 ;;       (list 'ids nil (ideographic-structure-to-ids value))
 466 ;;     (format "%s" value)))
 467 (defun est-eval-value-as-ids (value)
 468   (if (listp value)
 469       (list* 'ids
 470              nil
 471              (mapcar #'est-eval-value-as-object
 472                      (ideographic-structure-to-ids value))
 473              )
 474     (est-eval-value-default value)))
 475
 476 (defun est-eval-value-as-space-separated-ids (value)
 477   (if (listp value)
 478       (list* 'ids
 479              '(:separator " ")
 480              ;; (mapconcat #'char-to-string
 481              ;;            (ideographic-structure-to-ids value)
 482              ;;            " ")
 483              (mapcar #'est-eval-value-as-object
 484                      (ideographic-structure-to-ids value))
 485              )
 486     (est-eval-value-default value)))
 487
 488 (defun est-eval-value-as-domain-list (value)
 489   (if (listp value)
 490       (let (source item source-objs source0 start end num)
 491         (list* 'res-list
 492                '(:separator " ")
 493                (mapcar
 494                 (lambda (unit)
 495                   (setq unit
 496                         (if (symbolp unit)
 497                             (symbol-name unit)
 498                           (format "%s" unit)))
 499                   (cond
 500                    ((string-match "=" unit)
 501                     (setq source (intern
 502                                   (substring unit 0 (match-beginning 0)))
 503                           item (car (read-from-string
 504                                      (substring unit (match-end 0)))))
 505                     (cond
 506                      ((eq source 'bos)
 507                       (setq source-objs
 508                             (list
 509                              (est-eval-value-as-object
 510                               (or (concord-decode-object
 511                                    '=id item 'book@ruimoku)
 512                                   (concord-decode-object
 513                                    '=id item 'article@ruimoku)
 514                                   (intern unit)))))
 515                       )
 516                      ((memq source '(zob1959 zob1968))
 517                       (if (and (symbolp item)
 518                                (setq num (symbol-name item))
 519                                (string-match
 520                                 "^\\([0-9]+\\)-\\([0-9]+\\)$" num))
 521                           (setq start (string-to-number
 522                                        (match-string 1 num))
 523                                 end (string-to-number
 524                                      (match-string 2 num)))
 525                         (setq start item
 526                               end item))
 527                       (if (not (numberp start))
 528                           (setq source-objs
 529                                 (list
 530                                  (est-eval-value-as-object (intern unit))))
 531                         (if (eq source source0)
 532                             (setq source-objs
 533                                   (list
 534                                    (list 'link
 535                                          (list :ref
 536                                                (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 537                                                        start))
 538                                          start)))
 539                           (setq source0 source)
 540                           (setq source-objs
 541                                 (list
 542                                  (list 'link
 543                                        (list :ref
 544                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 545                                                      start))
 546                                        start)
 547                                  "="
 548                                  '(link
 549                                    (:ref "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/")
 550                                    "\u4EAC大人\u6587研甲\u9AA8")))
 551                           )
 552                         (setq num (1+ start))
 553                         (while (<= num end)
 554                           (setq source-objs
 555                                 (cons
 556                                  (list 'link
 557                                        (list :ref
 558                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 559                                                      num))
 560                                        num)
 561                                  source-objs))
 562                           (setq num (1+ num)))
 563                         (setq source-objs (nreverse source-objs)))
 564                       )
 565                      (t
 566                       (setq source-objs
 567                             (list (est-eval-value-as-object (intern unit))))
 568                       ))
 569                     (list* 'res-link
 570                            (list :separator " "
 571                                  :source source :item item)
 572                            source-objs)
 573                     )
 574                    (t
 575                     (list 'res-link nil unit)
 576                     )))
 577                 value)))
 578     (est-eval-value-default value)))
 579
 580 (defun est-eval-value-as-creators-names (value &optional subtype)
 581   (if (listp value)
 582       (let (role-name)
 583         (list* 'creator-name
 584                (if subtype
 585                    '(:subtype unordered-list)
 586                  '(:separator " "))
 587                (mapcar (lambda (creator)
 588                          (cond
 589                           ((concord-object-p creator)
 590                            (setq role-name
 591                                  (concord-object-get
 592                                   creator 'role*name))
 593                            (est-eval-list
 594                             (list
 595                              '(value (:feature ->creator/name))
 596                              (list
 597                               'object (list :object creator)
 598                               (or role-name
 599                                   (format "(%s)"
 600                                           (concord-object-get creator
 601                                                               'role*type)))))
 602                             creator nil)
 603                            )
 604                           (t creator)))
 605                        value)
 606                ))
 607     (est-eval-value-default value)))
 608
 609 (defun est-eval-value-as-created-works (value &optional subtype)
 610   (if (listp value)
 611       (list* 'creator-name
 612              (if subtype
 613                  '(:subtype unordered-list)
 614                '(:separator " "))
 615              (mapcar (lambda (creator)
 616                        (est-eval-list
 617                         '((value (:feature <-creator)))
 618                         creator nil))
 619                      value))
 620     (est-eval-value-default value)))
 621
 622 (defun est-eval-value-as-journal-volumes (value &optional subtype)
 623   (if (listp value)
 624       (list* 'journal-volumes
 625              (if subtype
 626                  '(:subtype unordered-list)
 627                '(:separator " "))
 628              (mapcar (lambda (volume)
 629                        (if (concord-object-p volume)
 630                            (est-eval-value-as-journal-volume volume 'short)
 631                          volume))
 632                      value))
 633     (est-eval-value-default value)))
 634
 635
 636 ;;; @ format evaluator
 637 ;;;
 638
 639 ;; (defun est-make-env (object feature-name)
 640 ;;   (list (cons 'object object)
 641 ;;         (cons 'feature-name feature-name)))
 642
 643 ;; (defun est-env-push-item (env item value)
 644 ;;   (cons (cons item value)
 645 ;;         env))
 646
 647 ;; (defun est-env-get-item (env item)
 648 ;;   (cdr (assq item env)))
 649
 650 ;; (defun est-env-current-value (env)
 651 ;;   (let ((obj (est-env-get-item env 'object))
 652 ;;         (feature (est-env-get-item env 'feature-name)))
 653 ;;     (if (characterp obj)
 654 ;;         (char-feature obj feature)
 655 ;;       (concord-object-get obj feature))))
 656
 657
 658 (defun est-eval-props-to-string (props &optional format)
 659   (unless format
 660     (setq format (plist-get props :format)))
 661   (concat "%"
 662           (plist-get props :flag)
 663           (if (plist-get props :len)
 664               (format "0%d"
 665                       (let ((ret (plist-get props :len)))
 666                         (if (stringp ret)
 667                             (string-to-int ret)
 668                           ret))))
 669           (cond
 670            ((eq format 'decimal) "d")
 671            ((eq format 'hex) "x")
 672            ((eq format 'HEX) "X")
 673            ((eq format 'S-exp) "S")
 674            (t "s"))))
 675
 676 (defun est-eval-apply-value (object feature-name format props value
 677                                     &optional uri-object)
 678   (list 'value
 679         (list :object object
 680               :feature feature-name)
 681         (cond
 682          ((memq format '(decimal hex HEX))
 683           (if (integerp value)
 684               (list format
 685                     nil
 686                     (format (est-eval-props-to-string props format)
 687                             value))
 688             (format "%s" value))
 689           )
 690          ((eq format 'string)
 691           (list 'string nil (format "%s" value))
 692           )
 693          ((eq format 'wiki-text)
 694           (est-eval-list value object feature-name nil uri-object)
 695           )
 696          ((eq format 'S-exp)
 697           (est-eval-value-as-S-exp value)
 698           )
 699          ((eq format 'ku-ten)
 700           (est-eval-value-as-kuten value))
 701          ((eq format 'kangxi-radical)
 702           (est-eval-value-as-kangxi-radical value))
 703          ((eq format 'ids)
 704           (est-eval-value-as-ids value))
 705          ((eq format 'decomposition)
 706           (est-eval-value-as-decomposition-list value))
 707          ((eq format 'composition)
 708           (est-eval-value-as-composition-list value))
 709          ((or (eq format 'space-separated)
 710               (eq format 'space-separated-char-list))
 711           (est-eval-value-as-object-list value " "))
 712          ((eq format 'char-list)
 713           (est-eval-value-as-char-list value nil))
 714          ((eq format 'unordered-list)
 715           (est-eval-value-as-object-list value nil 'unordered-list))
 716          ((eq format 'unordered-composition-list)
 717           (est-eval-value-as-composition-list value nil 'unordered-list))
 718          ((eq format 'space-separated-ids)
 719           (est-eval-value-as-space-separated-ids value))
 720          ((eq format 'space-separated-domain-list)
 721           (est-eval-value-as-domain-list value))
 722          ((eq format 'space-separated-creator-name-list)
 723           (est-eval-value-as-creators-names value))
 724          ((eq format 'unordered-creator-name-list)
 725           (est-eval-value-as-creators-names value 'unordered-list))
 726          ((eq format 'space-separated-created-work-list)
 727           (est-eval-value-as-created-works value))
 728          ((eq format 'unordered-created-work-list)
 729           (est-eval-value-as-created-works value 'unordered-list))
 730          ((eq format 'journal-volume-list)
 731           (est-eval-value-as-journal-volumes value))
 732          (t
 733           (est-eval-value-default value)
 734           ))
 735         ))
 736
 737 (defun est-eval-feature-value (object feature-name
 738                                       &optional format lang uri-object value)
 739   (unless value
 740     (setq value (www-get-feature-value object feature-name)))
 741   (unless format
 742     (setq format (www-feature-value-format feature-name)))
 743   (if (and (consp value)
 744            est-eval-list-feature-items-limit
 745            (not (eq feature-name 'sources)))
 746       (let ((ret (condition-case nil
 747                      (nthcdr est-eval-list-feature-items-limit value)
 748                    (error nil nil))))
 749         (when ret
 750           (setcdr ret
 751                   (list (list 'omitted
 752                               (list :object object :feature feature-name)
 753                               "..."))))))
 754   (cond
 755    ((symbolp format)
 756     (est-eval-apply-value object feature-name
 757                           format nil value
 758                           uri-object)
 759     )
 760    ((consp format)
 761     (cond
 762      ((null (cdr format))
 763       (setq format (car format))
 764       (est-eval-apply-value object feature-name
 765                             (car format) (nth 1 format) value
 766                             uri-object)
 767       )
 768      (t
 769       (est-eval-list format object feature-name lang uri-object)
 770       )))))
 771
 772 (defun est-eval-unit (exp object feature-name
 773                                  &optional lang uri-object value)
 774   (unless value
 775     (setq value (www-get-feature-value object feature-name)))
 776   (unless uri-object
 777     (setq uri-object (www-uri-encode-object object)))
 778   (cond
 779    ((stringp exp) exp)
 780    ((or (characterp exp)
 781         (concord-object-p exp))
 782     (est-eval-value-as-object exp)
 783     )
 784    ((null exp) "")
 785    ((consp exp)
 786     (cond
 787      ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
 788                               S-exp string default))
 789       (let ((fn (plist-get (nth 1 exp) :feature))
 790             domain domain-fn ret)
 791         (when fn
 792           (when (stringp fn)
 793             (setq fn (intern fn)))
 794           (setq domain (char-feature-name-domain feature-name))
 795           (setq domain-fn (char-feature-name-at-domain fn domain))
 796           (if (setq ret (www-get-feature-value object domain-fn))
 797               (setq feature-name domain-fn
 798                     value ret)
 799             (setq feature-name fn
 800                   value (www-get-feature-value object fn)))
 801           (push feature-name chise-wiki-displayed-features)
 802           ))
 803       (if (eq (car exp) 'value)
 804           (est-eval-feature-value object feature-name
 805                                          (plist-get (nth 1 exp) :format)
 806                                          lang uri-object value)
 807         (est-eval-apply-value
 808          object feature-name
 809          (car exp) (nth 1 exp) value
 810          uri-object))
 811       )
 812      ((eq (car exp) 'name)
 813       (let ((fn (plist-get (nth 1 exp) :feature))
 814             domain domain-fn)
 815         (when fn
 816           (setq domain (char-feature-name-domain feature-name))
 817           (when (stringp fn)
 818             (setq fn (intern fn)))
 819           (setq domain-fn (char-feature-name-at-domain fn domain))
 820           (setq feature-name domain-fn)))
 821       (list 'feature-name
 822             (list :object object
 823                   :feature feature-name)
 824             (www-format-feature-name* feature-name lang))
 825       )
 826      ((eq (car exp) 'name-url)
 827       (let ((fn (plist-get (nth 1 exp) :feature))
 828             (object (plist-get (nth 1 exp) :object))
 829             domain domain-fn)
 830         (when fn
 831           (setq domain (char-feature-name-domain feature-name))
 832           (when (stringp fn)
 833             (setq fn (intern fn)))
 834           (setq domain-fn (char-feature-name-at-domain fn domain))
 835           (setq feature-name domain-fn)))
 836       (list 'name-url (list :feature feature-name)
 837             (www-uri-make-feature-name-url
 838              (est-object-genre object)
 839              (www-uri-encode-feature-name feature-name)
 840              uri-object))
 841       )
 842      ((eq (car exp) 'domain-name)
 843       (let ((domain (char-feature-name-domain feature-name)))
 844         (if domain
 845             (format "@%s" domain)
 846           ""))
 847       )
 848      ((eq (car exp) 'omitted)
 849       (list 'omitted
 850             (list :object object :feature feature-name)
 851             "...")
 852       )
 853      ((eq (car exp) 'prev-char)
 854       (list 'prev-char
 855             (list :object object :feature feature-name)
 856             '(input (:type "submit" :value "-")))
 857       )
 858      ((eq (car exp) 'next-char)
 859       (list 'next-char
 860             (list :object object :feature feature-name)
 861             '(input (:type "submit" :value "+")))
 862       )
 863      ((eq (car exp) 'link)
 864       (list 'link
 865             (list :ref
 866                   (est-eval-list (plist-get (nth 1 exp) :ref)
 867                                         object feature-name lang uri-object))
 868             (est-eval-list (nthcdr 2 exp)
 869                                   object feature-name lang uri-object))
 870       )
 871      (t
 872       exp)))))
 873
 874 (defun est-eval-list (format-list object feature-name
 875                                   &optional lang uri-object)
 876   (if (consp format-list)
 877       (let ((ret
 878              (mapcar
 879               (lambda (exp)
 880                 (est-eval-unit exp object feature-name lang uri-object nil))
 881               format-list)))
 882         (if (cdr ret)
 883             (list* 'list nil ret)
 884           (car ret)))
 885     (est-eval-unit format-list object feature-name lang uri-object nil)))
 886
 887
 888 ;;; @ End.
 889 ;;;
 890
 891 (provide 'est-eval)
 892
 893 ;;; est-eval.el ends here