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-Web-yunzi-char (value)
 460   (if (char-or-char-int-p value)
 461       (list 'link
 462             (list :ref
 463                   (format "http://suzukish.s252.xrea.com/search/inkyo/yunzi/%c"
 464                           value))
 465             (format "/%s/" (char-to-string value)))))
 466
 467 (defun est-eval-value-as-object-list (value &optional separator subtype)
 468   (if (and (listp value)
 469            (listp (cdr value)))
 470       (condition-case nil
 471           (let (props)
 472             (if separator
 473                 (setq props (list :separator separator)))
 474             (if subtype
 475                 (setq props (list* :subtype subtype props)))
 476             (list* 'list props
 477                    (mapcar #'est-eval-value-as-object value)))
 478         (error (format "%s" value)))
 479     (format "%s" value)))
 480
 481 (defun est-eval-value-as-char-list (value &optional separator subtype)
 482   (if (and (listp value)
 483            (listp (cdr value)))
 484       (condition-case nil
 485           (let (props)
 486             (if separator
 487                 (setq props (list :separator separator)))
 488             (if subtype
 489                 (setq props (list* :subtype subtype props)))
 490             (list* 'list props
 491                    (mapcar #'est-eval-value-as-character value)))
 492         (error (format "%s" value)))
 493     (format "%s" value)))
 494
 495 (defun est-eval-value-as-location-list (value &optional separator subtype)
 496   (if (and (listp value)
 497            (listp (cdr value)))
 498       (condition-case nil
 499           (let (props)
 500             (if separator
 501                 (setq props (list :separator separator)))
 502             (if subtype
 503                 (setq props (list* :subtype subtype props)))
 504             (list* 'list props
 505                    (mapcar #'est-eval-value-as-location value)))
 506         (error (format "%s" value)))
 507     (format "%s" value)))
 508
 509 (defun est-eval-value-as-name-list (value &optional separator subtype)
 510   (if (and (listp value)
 511            (listp (cdr value)))
 512       (condition-case nil
 513           (let (props)
 514             (if separator
 515                 (setq props (list :separator separator)))
 516             (if subtype
 517                 (setq props (list* :subtype subtype props)))
 518             (list* 'list props
 519                    (mapcar #'est-eval-value-as-name value)))
 520         (error (format "%s" value)))
 521     (format "%s" value)))
 522
 523 (defun est-eval-value-as-image-list (value &optional separator subtype)
 524   (if (and (listp value)
 525            (listp (cdr value)))
 526       (condition-case nil
 527           (let (props)
 528             (if separator
 529                 (setq props (list :separator separator)))
 530             (if subtype
 531                 (setq props (list* :subtype subtype props)))
 532             (list* 'image-list props
 533                    (mapcar #'est-eval-value-as-image-object value)))
 534         (error (format "%s" value)))
 535     (format "%s" value)))
 536
 537 (defun est-eval-value-as-composition-list (value &optional separator subtype)
 538   (if (and (listp value)
 539            (listp (cdr value)))
 540       (condition-case nil
 541           (let (props)
 542             (if separator
 543                 (setq props (list :separator separator)))
 544             (if subtype
 545                 (setq props (list* :subtype subtype props)))
 546             (list* 'list props
 547                    (mapcar
 548                     (lambda (cell)
 549                       (list 'list nil
 550                             "+ "
 551                             (list 'object (list :object (car cell))
 552                                   (format "U+%04X" (car cell)))
 553                             " : "
 554                             (est-eval-value-as-object (cdr cell))))
 555                     (sort value
 556                           (lambda (a b)
 557                             (< (car a)(car b)))))))
 558         (error (format "%s" value)))
 559     (format "%s" value)))
 560
 561 (defun est-eval-value-as-decomposition-list (value)
 562   (if (and (listp value)
 563            (listp (cdr value)))
 564       (condition-case nil
 565           (let (props)
 566             (list* 'list props
 567                    (mapconcat #'char-to-string value "")
 568                    (list
 569                     " ("
 570                     (list* 'list '(:separator " + ")
 571                            (mapcar
 572                             (lambda (chr)
 573                               (list 'object (list :object chr)
 574                                     (format "U+%04X" chr)))
 575                             value))
 576                     ")")))
 577         (error (format "%s" value)))
 578     (format "%s" value)))
 579
 580 ;; (defun est-eval-value-as-ids (value)
 581 ;;   (if (listp value)
 582 ;;       (list 'ids nil (ideographic-structure-to-ids value))
 583 ;;     (format "%s" value)))
 584 (defun est-eval-value-as-ids (value)
 585   (if (listp value)
 586       (list* 'ids
 587              nil
 588              (mapcar #'est-eval-value-as-object
 589                      (ideographic-structure-to-ids value))
 590              )
 591     (est-eval-value-default value)))
 592
 593 (defun est-eval-value-as-space-separated-ids (value)
 594   (if (listp value)
 595       (list* 'ids
 596              '(:separator " ")
 597              ;; (mapconcat #'char-to-string
 598              ;;            (ideographic-structure-to-ids value)
 599              ;;            " ")
 600              (mapcar #'est-eval-value-as-object
 601                      (ideographic-structure-to-ids value))
 602              )
 603     (est-eval-value-default value)))
 604
 605 (defun est-eval-value-as-domain-list (value)
 606   (if (listp value)
 607       (let (source item source-objs source0 start end num)
 608         (list* 'res-list
 609                '(:separator " ")
 610                (mapcar
 611                 (lambda (unit)
 612                   (setq unit
 613                         (if (symbolp unit)
 614                             (symbol-name unit)
 615                           (format "%s" unit)))
 616                   (cond
 617                    ((string-match "=" unit)
 618                     (setq source (intern
 619                                   (substring unit 0 (match-beginning 0)))
 620                           item (car (read-from-string
 621                                      (substring unit (match-end 0)))))
 622                     (cond
 623                      ((eq source 'bos)
 624                       (setq source-objs
 625                             (list
 626                              (est-eval-value-as-object
 627                               (or (concord-decode-object
 628                                    '=id item 'book@ruimoku)
 629                                   (concord-decode-object
 630                                    '=id item 'article@ruimoku)
 631                                   (intern unit)))))
 632                       )
 633                      ((memq source '(zob1959 zob1968))
 634                       (if (and (symbolp item)
 635                                (setq num (symbol-name item))
 636                                (string-match
 637                                 "^\\([0-9]+\\)-\\([0-9]+\\)$" num))
 638                           (setq start (string-to-number
 639                                        (match-string 1 num))
 640                                 end (string-to-number
 641                                      (match-string 2 num)))
 642                         (setq start item
 643                               end item))
 644                       (if (not (numberp start))
 645                           (setq source-objs
 646                                 (list
 647                                  (est-eval-value-as-object (intern unit))))
 648                         (if (eq source source0)
 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                           (setq source0 source)
 657                           (setq source-objs
 658                                 (list
 659                                  (list 'link
 660                                        (list :ref
 661                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 662                                                      start))
 663                                        start)
 664                                  "="
 665                                  '(link
 666                                    (:ref "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/")
 667                                    "\u4EAC大人\u6587研甲\u9AA8")))
 668                           )
 669                         (setq num (1+ start))
 670                         (while (<= num end)
 671                           (setq source-objs
 672                                 (cons
 673                                  (list 'link
 674                                        (list :ref
 675                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 676                                                      num))
 677                                        num)
 678                                  source-objs))
 679                           (setq num (1+ num)))
 680                         (setq source-objs (nreverse source-objs)))
 681                       )
 682                      (t
 683                       (setq source-objs
 684                             (list (est-eval-value-as-object (intern unit))))
 685                       ))
 686                     (list* 'res-link
 687                            (list :separator " "
 688                                  :source source :item item)
 689                            source-objs)
 690                     )
 691                    (t
 692                     (list 'res-link nil unit)
 693                     )))
 694                 value)))
 695     (est-eval-value-default value)))
 696
 697 (defun est-eval-value-as-daijiten-page-list (value &optional separator subtype)
 698   (if (and (listp value)
 699            (listp (cdr value)))
 700       (condition-case nil
 701           (let (props)
 702             (if separator
 703                 (setq props (list :separator separator)))
 704             (if subtype
 705                 (setq props (list* :subtype subtype props)))
 706             (list* 'list props
 707                    (mapcar #'est-eval-value-as-daijiten-page value)))
 708         (error (format "%s" value)))
 709     (format "%s" value)))
 710
 711 (defun est-eval-value-as-Web-yunzi-char-list (value &optional separator subtype)
 712   (if (and (listp value)
 713            (listp (cdr value)))
 714       (condition-case nil
 715           (let (props)
 716             (if separator
 717                 (setq props (list :separator separator)))
 718             (if subtype
 719                 (setq props (list* :subtype subtype props)))
 720             (list* 'list props
 721                    (mapcar #'est-eval-value-as-Web-yunzi-char value)))
 722         (error (format "%s" value)))
 723     (format "%s" value)))
 724
 725 (defun est-eval-value-as-creators-names (value &optional subtype)
 726   (if (listp value)
 727       (let (role-name)
 728         (list* 'creator-name
 729                (if subtype
 730                    '(:subtype unordered-list)
 731                  '(:separator " "))
 732                (mapcar (lambda (creator)
 733                          (cond
 734                           ((concord-object-p creator)
 735                            (setq role-name
 736                                  (concord-object-get
 737                                   creator 'role*name))
 738                            (est-eval-list
 739                             (list
 740                              '(value (:feature ->creator/name))
 741                              (list
 742                               'object (list :object creator)
 743                               (or role-name
 744                                   (format "(%s)"
 745                                           (concord-object-get creator
 746                                                               'role*type)))))
 747                             creator nil)
 748                            )
 749                           (t creator)))
 750                        value)
 751                ))
 752     (est-eval-value-default value)))
 753
 754 (defun est-eval-value-as-created-works (value &optional subtype)
 755   (if (listp value)
 756       (list* 'creator-name
 757              (if subtype
 758                  '(:subtype unordered-list)
 759                '(:separator " "))
 760              (mapcar (lambda (creator)
 761                        (if (concord-object-p creator)
 762                            (est-eval-list
 763                             '((value (:feature <-creator)))
 764                             creator nil)
 765                          (est-eval-value-default creator)))
 766                      value))
 767     (est-eval-value-default value)))
 768
 769 (defun est-eval-value-as-journal-volumes (value &optional subtype)
 770   (if (listp value)
 771       (list* 'journal-volumes
 772              (if subtype
 773                  '(:subtype unordered-list)
 774                '(:separator " "))
 775              (mapcar (lambda (volume)
 776                        (if (concord-object-p volume)
 777                            (est-eval-value-as-journal-volume volume 'short)
 778                          volume))
 779                      value))
 780     (est-eval-value-default value)))
 781
 782
 783 ;;; @ format evaluator
 784 ;;;
 785
 786 ;; (defun est-make-env (object feature-name)
 787 ;;   (list (cons 'object object)
 788 ;;         (cons 'feature-name feature-name)))
 789
 790 ;; (defun est-env-push-item (env item value)
 791 ;;   (cons (cons item value)
 792 ;;         env))
 793
 794 ;; (defun est-env-get-item (env item)
 795 ;;   (cdr (assq item env)))
 796
 797 ;; (defun est-env-current-value (env)
 798 ;;   (let ((obj (est-env-get-item env 'object))
 799 ;;         (feature (est-env-get-item env 'feature-name)))
 800 ;;     (if (characterp obj)
 801 ;;         (char-feature obj feature)
 802 ;;       (concord-object-get obj feature))))
 803
 804
 805 (defun est-eval-props-to-string (props &optional format)
 806   (unless format
 807     (setq format (plist-get props :format)))
 808   (concat "%"
 809           (plist-get props :flag)
 810           (if (plist-get props :len)
 811               (format "0%d"
 812                       (let ((ret (plist-get props :len)))
 813                         (if (stringp ret)
 814                             (string-to-int ret)
 815                           ret))))
 816           (cond
 817            ((eq format 'decimal) "d")
 818            ((eq format 'hex) "x")
 819            ((eq format 'HEX) "X")
 820            ((eq format 'S-exp) "S")
 821            (t "s"))))
 822
 823 (defun est-eval-apply-value (object feature-name format props value
 824                                     &optional uri-object)
 825   (list 'value
 826         (list :object object
 827               :feature feature-name)
 828         (cond
 829          ((memq format '(decimal hex HEX))
 830           (if (integerp value)
 831               (list format
 832                     nil
 833                     (format (est-eval-props-to-string props format)
 834                             value))
 835             (format "%s" value))
 836           )
 837          ((eq format 'string)
 838           (list 'string nil (format "%s" value))
 839           )
 840          ((eq format 'wiki-text)
 841           (est-eval-list value object feature-name nil uri-object)
 842           )
 843          ((eq format 'unordered-link-list)
 844           (est-eval-list value object feature-name nil uri-object
 845                          '(:subtype unordered-list :separator " "))
 846           )
 847          ((eq format 'S-exp)
 848           (est-eval-value-as-S-exp value)
 849           )
 850          ((eq format 'ku-ten)
 851           (est-eval-value-as-kuten value))
 852          ((eq format 'kangxi-radical)
 853           (est-eval-value-as-kangxi-radical value))
 854          ((eq format 'shuowen-radical)
 855           (est-eval-value-as-shuowen-radical value))
 856          ((eq format 'ids)
 857           (est-eval-value-as-ids value))
 858          ((eq format 'decomposition)
 859           (est-eval-value-as-decomposition-list value))
 860          ((eq format 'composition)
 861           (est-eval-value-as-composition-list value))
 862          ((or (eq format 'space-separated)
 863               (eq format 'space-separated-char-list))
 864           (est-eval-value-as-object-list value " "))
 865          ((eq format 'char-list)
 866           (est-eval-value-as-char-list value nil))
 867          ((eq format 'location-list)
 868           (est-eval-value-as-location-list value nil))
 869          ((eq format 'name-list)
 870           (est-eval-value-as-name-list value nil))
 871          ((eq format 'image-list)
 872           (est-eval-value-as-image-list value nil))
 873          ((eq format 'unordered-list)
 874           (est-eval-value-as-object-list value nil 'unordered-list))
 875          ((eq format 'unordered-composition-list)
 876           (est-eval-value-as-composition-list value nil 'unordered-list))
 877          ((eq format 'space-separated-ids)
 878           (est-eval-value-as-space-separated-ids value))
 879          ((eq format 'space-separated-domain-list)
 880           (est-eval-value-as-domain-list value))
 881          ((eq format 'space-separated-creator-name-list)
 882           (est-eval-value-as-creators-names value))
 883          ((eq format 'unordered-creator-name-list)
 884           (est-eval-value-as-creators-names value 'unordered-list))
 885          ((eq format 'space-separated-created-work-list)
 886           (est-eval-value-as-created-works value))
 887          ((eq format 'unordered-created-work-list)
 888           (est-eval-value-as-created-works value 'unordered-list))
 889          ((eq format 'journal-volume-list)
 890           (est-eval-value-as-journal-volumes value))
 891          ((eq format 'space-separated-daijiten-page-list)
 892           (est-eval-value-as-daijiten-page-list value " "))
 893          ((eq format 'space-separated-Web-yunzi-char-list)
 894           (est-eval-value-as-Web-yunzi-char-list value " "))
 895          (t
 896           (est-eval-value-default value)
 897           ))
 898         ))
 899
 900 (defun est-eval-feature-value (object feature-name
 901                                       &optional format lang uri-object value)
 902   (unless value
 903     (setq value (www-get-feature-value object feature-name)))
 904   (unless format
 905     (setq format (www-feature-value-format feature-name)))
 906   (if (and (consp value)
 907            est-eval-list-feature-items-limit
 908            (not (eq feature-name 'sources)))
 909       (let ((ret (condition-case nil
 910                      (nthcdr est-eval-list-feature-items-limit value)
 911                    (error nil nil))))
 912         (when ret
 913           (setcdr ret
 914                   (list (list 'omitted
 915                               (list :object object :feature feature-name)
 916                               "..."))))))
 917   (cond
 918    ((symbolp format)
 919     (est-eval-apply-value object feature-name
 920                           format nil value
 921                           uri-object)
 922     )
 923    ((consp format)
 924     (cond
 925      ((null (cdr format))
 926       (setq format (car format))
 927       (est-eval-apply-value object feature-name
 928                             (car format) (nth 1 format) value
 929                             uri-object)
 930       )
 931      (t
 932       (est-eval-list format object feature-name lang uri-object)
 933       )))))
 934
 935 (defun est-eval-unit (exp object feature-name
 936                                  &optional lang uri-object value)
 937   (unless value
 938     (setq value (www-get-feature-value object feature-name)))
 939   (unless uri-object
 940     (setq uri-object (www-uri-encode-object object)))
 941   (cond
 942    ((stringp exp) exp)
 943    ((or (characterp exp)
 944         (concord-object-p exp))
 945     (est-eval-value-as-object exp)
 946     )
 947    ((null exp) "")
 948    ((consp exp)
 949     (cond
 950      ((memq (car exp) '(value decimal hex HEX ku-ten
 951                               kangxi-radical shuowen-radical
 952                               S-exp string default))
 953       (let ((fn (plist-get (nth 1 exp) :feature))
 954             domain domain-fn ret)
 955         (when fn
 956           (when (stringp fn)
 957             (setq fn (intern fn)))
 958           (setq domain (char-feature-name-domain feature-name))
 959           (setq domain-fn (char-feature-name-at-domain fn domain))
 960           (if (setq ret (www-get-feature-value object domain-fn))
 961               (setq feature-name domain-fn
 962                     value ret)
 963             (setq feature-name fn
 964                   value (www-get-feature-value object fn)))
 965           (push feature-name chise-wiki-displayed-features)
 966           ))
 967       (if (eq (car exp) 'value)
 968           (est-eval-feature-value object feature-name
 969                                          (plist-get (nth 1 exp) :format)
 970                                          lang uri-object value)
 971         (est-eval-apply-value
 972          object feature-name
 973          (car exp) (nth 1 exp) value
 974          uri-object))
 975       )
 976      ((eq (car exp) 'name)
 977       (let ((fn (plist-get (nth 1 exp) :feature))
 978             domain domain-fn)
 979         (when fn
 980           (setq domain (char-feature-name-domain feature-name))
 981           (when (stringp fn)
 982             (setq fn (intern fn)))
 983           (setq domain-fn (char-feature-name-at-domain fn domain))
 984           (setq feature-name domain-fn)))
 985       (list 'feature-name
 986             (list :object object
 987                   :feature feature-name)
 988             (www-format-feature-name* feature-name lang))
 989       )
 990      ((eq (car exp) 'name-url)
 991       (let ((fn (plist-get (nth 1 exp) :feature))
 992             (object (plist-get (nth 1 exp) :object))
 993             domain domain-fn)
 994         (when fn
 995           (setq domain (char-feature-name-domain feature-name))
 996           (when (stringp fn)
 997             (setq fn (intern fn)))
 998           (setq domain-fn (char-feature-name-at-domain fn domain))
 999           (setq feature-name domain-fn)))
1000       (list 'name-url (list :feature feature-name)
1001             (www-uri-make-feature-name-url
1002              (est-object-genre object)
1003              (www-uri-encode-feature-name feature-name)
1004              uri-object))
1005       )
1006      ((eq (car exp) 'domain-name)
1007       (let ((domain (char-feature-name-domain feature-name)))
1008         (if domain
1009             (format "@%s" domain)
1010           ""))
1011       )
1012      ((eq (car exp) 'omitted)
1013       (list 'omitted
1014             (list :object object :feature feature-name)
1015             "...")
1016       )
1017      ((eq (car exp) 'prev-char)
1018       (list 'prev-char
1019             (list :object object :feature feature-name)
1020             '(input (:type "submit" :value "-")))
1021       )
1022      ((eq (car exp) 'next-char)
1023       (list 'next-char
1024             (list :object object :feature feature-name)
1025             '(input (:type "submit" :value "+")))
1026       )
1027      ((eq (car exp) 'link)
1028       (list 'link
1029             (list :ref
1030                   (est-eval-list (plist-get (nth 1 exp) :ref)
1031                                         object feature-name lang uri-object))
1032             (est-eval-list (nthcdr 2 exp)
1033                                   object feature-name lang uri-object))
1034       )
1035      (t
1036       exp)))))
1037
1038 (defun est-eval-list (format-list object feature-name
1039                                   &optional lang uri-object list-props)
1040   (if (consp format-list)
1041       (let ((ret
1042              (mapcar
1043               (lambda (exp)
1044                 (est-eval-unit exp object feature-name lang uri-object nil))
1045               format-list)))
1046         (if (cdr ret)
1047             (list* 'list list-props ret)
1048           (car ret)))
1049     (est-eval-unit format-list object feature-name lang uri-object nil)))
1050
1051
1052 ;;; @ End.
1053 ;;;
1054
1055 (provide 'est-eval)
1056
1057 ;;; est-eval.el ends here