est-eval.el

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