est-eval.el

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