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