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-HEX (value)
 362   (if (integerp value)
 363       (list 'HEX nil (format "%X" value))
 364     (est-eval-value-as-S-exp value)))
 365
 366 (defun est-eval-value-as-kuten (value)
 367   (if (integerp value)
 368       (list 'ku-ten
 369             nil
 370             (format "%02d-%02d"
 371                     (- (lsh value -8) 32)
 372                     (- (logand value 255) 32)))
 373     (est-eval-value-as-S-exp value)))
 374
 375 (defun est-eval-value-as-kangxi-radical (value)
 376   (if (and (integerp value)
 377            (<= 0 value)
 378            (<= value 214))
 379       (list 'kangxi-radical
 380             nil
 381             (format "%c" (ideographic-radical value)))
 382     (est-eval-value-as-S-exp value)))
 383
 384 (defun est-eval-value-as-object-list (value &optional separator subtype)
 385   (if (and (listp value)
 386            (listp (cdr value)))
 387       (condition-case nil
 388           (let (props)
 389             (if separator
 390                 (setq props (list :separator separator)))
 391             (if subtype
 392                 (setq props (list* :subtype subtype props)))
 393             (list* 'list props
 394                    (mapcar #'est-eval-value-as-object value)))
 395         (error (format "%s" value)))
 396     (format "%s" value)))
 397
 398 (defun est-eval-value-as-composition-list (value &optional separator subtype)
 399   (if (and (listp value)
 400            (listp (cdr value)))
 401       (condition-case nil
 402           (let (props)
 403             (if separator
 404                 (setq props (list :separator separator)))
 405             (if subtype
 406                 (setq props (list* :subtype subtype props)))
 407             (list* 'list props
 408                    (mapcar
 409                     (lambda (cell)
 410                       (list 'list nil
 411                             "+ "
 412                             (list 'object (list :object (car cell))
 413                                   (format "U+%04X" (car cell)))
 414                             " : "
 415                             (est-eval-value-as-object (cdr cell))))
 416                     (sort value
 417                           (lambda (a b)
 418                             (< (car a)(car b)))))))
 419         (error (format "%s" value)))
 420     (format "%s" value)))
 421
 422 (defun est-eval-value-as-decomposition-list (value)
 423   (if (and (listp value)
 424            (listp (cdr value)))
 425       (condition-case nil
 426           (let (props)
 427             (list* 'list props
 428                    (mapconcat #'char-to-string value "")
 429                    (list
 430                     " ("
 431                     (list* 'list '(:separator " + ")
 432                            (mapcar
 433                             (lambda (chr)
 434                               (list 'object (list :object chr)
 435                                     (format "U+%04X" chr)))
 436                             value))
 437                     ")")))
 438         (error (format "%s" value)))
 439     (format "%s" value)))
 440
 441 ;; (defun est-eval-value-as-ids (value)
 442 ;;   (if (listp value)
 443 ;;       (list 'ids nil (ideographic-structure-to-ids value))
 444 ;;     (format "%s" value)))
 445 (defun est-eval-value-as-ids (value)
 446   (if (listp value)
 447       (list* 'ids
 448              nil
 449              (mapcar #'est-eval-value-as-object
 450                      (ideographic-structure-to-ids value))
 451              )
 452     (est-eval-value-default value)))
 453
 454 (defun est-eval-value-as-space-separated-ids (value)
 455   (if (listp value)
 456       (list* 'ids
 457              '(:separator " ")
 458              ;; (mapconcat #'char-to-string
 459              ;;            (ideographic-structure-to-ids value)
 460              ;;            " ")
 461              (mapcar #'est-eval-value-as-object
 462                      (ideographic-structure-to-ids value))
 463              )
 464     (est-eval-value-default value)))
 465
 466 (defun est-eval-value-as-domain-list (value)
 467   (if (listp value)
 468       (let (source item source-objs source0 start end num)
 469         (list* 'res-list
 470                '(:separator " ")
 471                (mapcar
 472                 (lambda (unit)
 473                   (setq unit
 474                         (if (symbolp unit)
 475                             (symbol-name unit)
 476                           (format "%s" unit)))
 477                   (cond
 478                    ((string-match "=" unit)
 479                     (setq source (intern
 480                                   (substring unit 0 (match-beginning 0)))
 481                           item (car (read-from-string
 482                                      (substring unit (match-end 0)))))
 483                     (cond
 484                      ((eq source 'bos)
 485                       (setq source-objs
 486                             (list
 487                              (est-eval-value-as-object
 488                               (or (concord-decode-object
 489                                    '=id item 'book@ruimoku)
 490                                   (concord-decode-object
 491                                    '=id item 'article@ruimoku)
 492                                   (intern unit)))))
 493                       )
 494                      ((memq source '(zob1959 zob1968))
 495                       (if (and (symbolp item)
 496                                (setq num (symbol-name item))
 497                                (string-match
 498                                 "^\\([0-9]+\\)-\\([0-9]+\\)$" num))
 499                           (setq start (string-to-number
 500                                        (match-string 1 num))
 501                                 end (string-to-number
 502                                      (match-string 2 num)))
 503                         (setq start item
 504                               end item))
 505                       (if (not (numberp start))
 506                           (setq source-objs
 507                                 (list
 508                                  (est-eval-value-as-object (intern unit))))
 509                         (if (eq source source0)
 510                             (setq source-objs
 511                                   (list
 512                                    (list 'link
 513                                          (list :ref
 514                                                (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 515                                                        start))
 516                                          start)))
 517                           (setq source0 source)
 518                           (setq source-objs
 519                                 (list
 520                                  (list 'link
 521                                        (list :ref
 522                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 523                                                      start))
 524                                        start)
 525                                  "="
 526                                  '(link
 527                                    (:ref "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/")
 528                                    "\u4EAC大人\u6587研甲\u9AA8")))
 529                           )
 530                         (setq num (1+ start))
 531                         (while (<= num end)
 532                           (setq source-objs
 533                                 (cons
 534                                  (list 'link
 535                                        (list :ref
 536                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 537                                                      num))
 538                                        num)
 539                                  source-objs))
 540                           (setq num (1+ num)))
 541                         (setq source-objs (nreverse source-objs)))
 542                       )
 543                      (t
 544                       (setq source-objs
 545                             (list (est-eval-value-as-object (intern unit))))
 546                       ))
 547                     (list* 'res-link
 548                            (list :separator " "
 549                                  :source source :item item)
 550                            source-objs)
 551                     )
 552                    (t
 553                     (list 'res-link nil unit)
 554                     )))
 555                 value)))
 556     (est-eval-value-default value)))
 557
 558 (defun est-eval-value-as-creators-names (value &optional subtype)
 559   (if (listp value)
 560       (let (role-name)
 561         (list* 'creator-name
 562                (if subtype
 563                    '(:subtype unordered-list)
 564                  '(:separator " "))
 565                (mapcar (lambda (creator)
 566                          (cond
 567                           ((concord-object-p creator)
 568                            (setq role-name
 569                                  (concord-object-get
 570                                   creator 'role*name))
 571                            (est-eval-list
 572                             (list
 573                              '(value (:feature ->creator/name))
 574                              (list
 575                               'object (list :object creator)
 576                               (or role-name
 577                                   (format "(%s)"
 578                                           (concord-object-get creator
 579                                                               'role*type)))))
 580                             creator nil)
 581                            )
 582                           (t creator)))
 583                        value)
 584                ))
 585     (est-eval-value-default value)))
 586
 587 (defun est-eval-value-as-created-works (value &optional subtype)
 588   (if (listp value)
 589       (list* 'creator-name
 590              (if subtype
 591                  '(:subtype unordered-list)
 592                '(:separator " "))
 593              (mapcar (lambda (creator)
 594                        (est-eval-list
 595                         '((value (:feature <-creator)))
 596                         creator nil))
 597                      value))
 598     (est-eval-value-default value)))
 599
 600 (defun est-eval-value-as-journal-volumes (value &optional subtype)
 601   (if (listp value)
 602       (list* 'journal-volumes
 603              (if subtype
 604                  '(:subtype unordered-list)
 605                '(:separator " "))
 606              (mapcar (lambda (volume)
 607                        (if (concord-object-p volume)
 608                            (est-eval-value-as-journal-volume volume 'short)
 609                          volume))
 610                      value))
 611     (est-eval-value-default value)))
 612
 613
 614 ;;; @ format evaluator
 615 ;;;
 616
 617 ;; (defun est-make-env (object feature-name)
 618 ;;   (list (cons 'object object)
 619 ;;         (cons 'feature-name feature-name)))
 620
 621 ;; (defun est-env-push-item (env item value)
 622 ;;   (cons (cons item value)
 623 ;;         env))
 624
 625 ;; (defun est-env-get-item (env item)
 626 ;;   (cdr (assq item env)))
 627
 628 ;; (defun est-env-current-value (env)
 629 ;;   (let ((obj (est-env-get-item env 'object))
 630 ;;         (feature (est-env-get-item env 'feature-name)))
 631 ;;     (if (characterp obj)
 632 ;;         (char-feature obj feature)
 633 ;;       (concord-object-get obj feature))))
 634
 635
 636 (defun est-eval-props-to-string (props &optional format)
 637   (unless format
 638     (setq format (plist-get props :format)))
 639   (concat "%"
 640           (plist-get props :flag)
 641           (if (plist-get props :len)
 642               (format "0%d"
 643                       (let ((ret (plist-get props :len)))
 644                         (if (stringp ret)
 645                             (string-to-int ret)
 646                           ret))))
 647           (cond
 648            ((eq format 'decimal) "d")
 649            ((eq format 'hex) "x")
 650            ((eq format 'HEX) "X")
 651            ((eq format 'S-exp) "S")
 652            (t "s"))))
 653
 654 (defun est-eval-apply-value (object feature-name format props value
 655                                     &optional uri-object)
 656   (list 'value
 657         (list :object object
 658               :feature feature-name)
 659         (cond
 660          ((memq format '(decimal hex HEX))
 661           (if (integerp value)
 662               (list format
 663                     nil
 664                     (format (est-eval-props-to-string props format)
 665                             value))
 666             (format "%s" value))
 667           )
 668          ((eq format 'string)
 669           (list 'string nil (format "%s" value))
 670           )
 671          ((eq format 'wiki-text)
 672           (est-eval-list value object feature-name nil uri-object)
 673           )
 674          ((eq format 'S-exp)
 675           (est-eval-value-as-S-exp value)
 676           )
 677          ((eq format 'ku-ten)
 678           (est-eval-value-as-kuten value))
 679          ((eq format 'kangxi-radical)
 680           (est-eval-value-as-kangxi-radical value))
 681          ((eq format 'ids)
 682           (est-eval-value-as-ids value))
 683          ((eq format 'decomposition)
 684           (est-eval-value-as-decomposition-list value))
 685          ((eq format 'composition)
 686           (est-eval-value-as-composition-list value))
 687          ((or (eq format 'space-separated)
 688               (eq format 'space-separated-char-list))
 689           (est-eval-value-as-object-list value " "))
 690          ((eq format 'unordered-list)
 691           (est-eval-value-as-object-list value nil 'unordered-list))
 692          ((eq format 'unordered-composition-list)
 693           (est-eval-value-as-composition-list value nil 'unordered-list))
 694          ((eq format 'space-separated-ids)
 695           (est-eval-value-as-space-separated-ids value))
 696          ((eq format 'space-separated-domain-list)
 697           (est-eval-value-as-domain-list value))
 698          ((eq format 'space-separated-creator-name-list)
 699           (est-eval-value-as-creators-names value))
 700          ((eq format 'unordered-creator-name-list)
 701           (est-eval-value-as-creators-names value 'unordered-list))
 702          ((eq format 'space-separated-created-work-list)
 703           (est-eval-value-as-created-works value))
 704          ((eq format 'unordered-created-work-list)
 705           (est-eval-value-as-created-works value 'unordered-list))
 706          ((eq format 'journal-volume-list)
 707           (est-eval-value-as-journal-volumes value))
 708          (t
 709           (est-eval-value-default value)
 710           ))
 711         ))
 712
 713 (defun est-eval-feature-value (object feature-name
 714                                       &optional format lang uri-object value)
 715   (unless value
 716     (setq value (www-get-feature-value object feature-name)))
 717   (unless format
 718     (setq format (www-feature-value-format feature-name)))
 719   (if (and (consp value)
 720            est-eval-list-feature-items-limit
 721            (not (eq feature-name 'sources)))
 722       (let ((ret (condition-case nil
 723                      (nthcdr est-eval-list-feature-items-limit value)
 724                    (error nil nil))))
 725         (when ret
 726           (setcdr ret
 727                   (list (list 'omitted
 728                               (list :object object :feature feature-name)
 729                               "..."))))))
 730   (cond
 731    ((symbolp format)
 732     (est-eval-apply-value object feature-name
 733                           format nil value
 734                           uri-object)
 735     )
 736    ((consp format)
 737     (cond
 738      ((null (cdr format))
 739       (setq format (car format))
 740       (est-eval-apply-value object feature-name
 741                             (car format) (nth 1 format) value
 742                             uri-object)
 743       )
 744      (t
 745       (est-eval-list format object feature-name lang uri-object)
 746       )))))
 747
 748 (defun est-eval-unit (exp object feature-name
 749                                  &optional lang uri-object value)
 750   (unless value
 751     (setq value (www-get-feature-value object feature-name)))
 752   (unless uri-object
 753     (setq uri-object (www-uri-encode-object object)))
 754   (cond
 755    ((stringp exp) exp)
 756    ((or (characterp exp)
 757         (concord-object-p exp))
 758     (est-eval-value-as-object exp)
 759     )
 760    ((null exp) "")
 761    ((consp exp)
 762     (cond
 763      ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
 764                               S-exp string default))
 765       (let ((fn (plist-get (nth 1 exp) :feature))
 766             domain domain-fn ret)
 767         (when fn
 768           (when (stringp fn)
 769             (setq fn (intern fn)))
 770           (setq domain (char-feature-name-domain feature-name))
 771           (setq domain-fn (char-feature-name-at-domain fn domain))
 772           (if (setq ret (www-get-feature-value object domain-fn))
 773               (setq feature-name domain-fn
 774                     value ret)
 775             (setq feature-name fn
 776                   value (www-get-feature-value object fn)))
 777           (push feature-name chise-wiki-displayed-features)
 778           ))
 779       (if (eq (car exp) 'value)
 780           (est-eval-feature-value object feature-name
 781                                          (plist-get (nth 1 exp) :format)
 782                                          lang uri-object value)
 783         (est-eval-apply-value
 784          object feature-name
 785          (car exp) (nth 1 exp) value
 786          uri-object))
 787       )
 788      ((eq (car exp) 'name)
 789       (let ((fn (plist-get (nth 1 exp) :feature))
 790             domain domain-fn)
 791         (when fn
 792           (setq domain (char-feature-name-domain feature-name))
 793           (when (stringp fn)
 794             (setq fn (intern fn)))
 795           (setq domain-fn (char-feature-name-at-domain fn domain))
 796           (setq feature-name domain-fn)))
 797       (list 'feature-name
 798             (list :object object
 799                   :feature feature-name)
 800             (www-format-feature-name* feature-name lang))
 801       )
 802      ((eq (car exp) 'name-url)
 803       (let ((fn (plist-get (nth 1 exp) :feature))
 804             (object (plist-get (nth 1 exp) :object))
 805             domain domain-fn)
 806         (when fn
 807           (setq domain (char-feature-name-domain feature-name))
 808           (when (stringp fn)
 809             (setq fn (intern fn)))
 810           (setq domain-fn (char-feature-name-at-domain fn domain))
 811           (setq feature-name domain-fn)))
 812       (list 'name-url (list :feature feature-name)
 813             (www-uri-make-feature-name-url
 814              (est-object-genre object)
 815              (www-uri-encode-feature-name feature-name)
 816              uri-object))
 817       )
 818      ((eq (car exp) 'domain-name)
 819       (let ((domain (char-feature-name-domain feature-name)))
 820         (if domain
 821             (format "@%s" domain)
 822           ""))
 823       )
 824      ((eq (car exp) 'omitted)
 825       (list 'omitted
 826             (list :object object :feature feature-name)
 827             "...")
 828       )
 829      ((eq (car exp) 'prev-char)
 830       (list 'prev-char
 831             (list :object object :feature feature-name)
 832             '(input (:type "submit" :value "-")))
 833       )
 834      ((eq (car exp) 'next-char)
 835       (list 'next-char
 836             (list :object object :feature feature-name)
 837             '(input (:type "submit" :value "+")))
 838       )
 839      ((eq (car exp) 'link)
 840       (list 'link
 841             (list :ref
 842                   (est-eval-list (plist-get (nth 1 exp) :ref)
 843                                         object feature-name lang uri-object))
 844             (est-eval-list (nthcdr 2 exp)
 845                                   object feature-name lang uri-object))
 846       )
 847      (t
 848       exp)))))
 849
 850 (defun est-eval-list (format-list object feature-name
 851                                   &optional lang uri-object)
 852   (if (consp format-list)
 853       (let ((ret
 854              (mapcar
 855               (lambda (exp)
 856                 (est-eval-unit exp object feature-name lang uri-object nil))
 857               format-list)))
 858         (if (cdr ret)
 859             (list* 'list nil ret)
 860           (car ret)))
 861     (est-eval-unit format-list object feature-name lang uri-object nil)))
 862
 863
 864 ;;; @ End.
 865 ;;;
 866
 867 (provide 'est-eval)
 868
 869 ;;; est-eval.el ends here