est-eval.el

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