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