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