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