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