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