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-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 'unordered-link-list)
 778           (est-eval-list value object feature-name nil uri-object
 779                          '(:subtype unordered-list :separator " "))
 780           )
 781          ((eq format 'S-exp)
 782           (est-eval-value-as-S-exp value)
 783           )
 784          ((eq format 'ku-ten)
 785           (est-eval-value-as-kuten value))
 786          ((eq format 'kangxi-radical)
 787           (est-eval-value-as-kangxi-radical value))
 788          ((eq format 'ids)
 789           (est-eval-value-as-ids value))
 790          ((eq format 'decomposition)
 791           (est-eval-value-as-decomposition-list value))
 792          ((eq format 'composition)
 793           (est-eval-value-as-composition-list value))
 794          ((or (eq format 'space-separated)
 795               (eq format 'space-separated-char-list))
 796           (est-eval-value-as-object-list value " "))
 797          ((eq format 'char-list)
 798           (est-eval-value-as-char-list value nil))
 799          ((eq format 'location-list)
 800           (est-eval-value-as-location-list value nil))
 801          ((eq format 'name-list)
 802           (est-eval-value-as-name-list value nil))
 803          ((eq format 'image-list)
 804           (est-eval-value-as-image-list value nil))
 805          ((eq format 'unordered-list)
 806           (est-eval-value-as-object-list value nil 'unordered-list))
 807          ((eq format 'unordered-composition-list)
 808           (est-eval-value-as-composition-list value nil 'unordered-list))
 809          ((eq format 'space-separated-ids)
 810           (est-eval-value-as-space-separated-ids value))
 811          ((eq format 'space-separated-domain-list)
 812           (est-eval-value-as-domain-list value))
 813          ((eq format 'space-separated-creator-name-list)
 814           (est-eval-value-as-creators-names value))
 815          ((eq format 'unordered-creator-name-list)
 816           (est-eval-value-as-creators-names value 'unordered-list))
 817          ((eq format 'space-separated-created-work-list)
 818           (est-eval-value-as-created-works value))
 819          ((eq format 'unordered-created-work-list)
 820           (est-eval-value-as-created-works value 'unordered-list))
 821          ((eq format 'journal-volume-list)
 822           (est-eval-value-as-journal-volumes value))
 823          (t
 824           (est-eval-value-default value)
 825           ))
 826         ))
 827
 828 (defun est-eval-feature-value (object feature-name
 829                                       &optional format lang uri-object value)
 830   (unless value
 831     (setq value (www-get-feature-value object feature-name)))
 832   (unless format
 833     (setq format (www-feature-value-format feature-name)))
 834   (if (and (consp value)
 835            est-eval-list-feature-items-limit
 836            (not (eq feature-name 'sources)))
 837       (let ((ret (condition-case nil
 838                      (nthcdr est-eval-list-feature-items-limit value)
 839                    (error nil nil))))
 840         (when ret
 841           (setcdr ret
 842                   (list (list 'omitted
 843                               (list :object object :feature feature-name)
 844                               "..."))))))
 845   (cond
 846    ((symbolp format)
 847     (est-eval-apply-value object feature-name
 848                           format nil value
 849                           uri-object)
 850     )
 851    ((consp format)
 852     (cond
 853      ((null (cdr format))
 854       (setq format (car format))
 855       (est-eval-apply-value object feature-name
 856                             (car format) (nth 1 format) value
 857                             uri-object)
 858       )
 859      (t
 860       (est-eval-list format object feature-name lang uri-object)
 861       )))))
 862
 863 (defun est-eval-unit (exp object feature-name
 864                                  &optional lang uri-object value)
 865   (unless value
 866     (setq value (www-get-feature-value object feature-name)))
 867   (unless uri-object
 868     (setq uri-object (www-uri-encode-object object)))
 869   (cond
 870    ((stringp exp) exp)
 871    ((or (characterp exp)
 872         (concord-object-p exp))
 873     (est-eval-value-as-object exp)
 874     )
 875    ((null exp) "")
 876    ((consp exp)
 877     (cond
 878      ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
 879                               S-exp string default))
 880       (let ((fn (plist-get (nth 1 exp) :feature))
 881             domain domain-fn ret)
 882         (when fn
 883           (when (stringp fn)
 884             (setq fn (intern fn)))
 885           (setq domain (char-feature-name-domain feature-name))
 886           (setq domain-fn (char-feature-name-at-domain fn domain))
 887           (if (setq ret (www-get-feature-value object domain-fn))
 888               (setq feature-name domain-fn
 889                     value ret)
 890             (setq feature-name fn
 891                   value (www-get-feature-value object fn)))
 892           (push feature-name chise-wiki-displayed-features)
 893           ))
 894       (if (eq (car exp) 'value)
 895           (est-eval-feature-value object feature-name
 896                                          (plist-get (nth 1 exp) :format)
 897                                          lang uri-object value)
 898         (est-eval-apply-value
 899          object feature-name
 900          (car exp) (nth 1 exp) value
 901          uri-object))
 902       )
 903      ((eq (car exp) 'name)
 904       (let ((fn (plist-get (nth 1 exp) :feature))
 905             domain domain-fn)
 906         (when fn
 907           (setq domain (char-feature-name-domain feature-name))
 908           (when (stringp fn)
 909             (setq fn (intern fn)))
 910           (setq domain-fn (char-feature-name-at-domain fn domain))
 911           (setq feature-name domain-fn)))
 912       (list 'feature-name
 913             (list :object object
 914                   :feature feature-name)
 915             (www-format-feature-name* feature-name lang))
 916       )
 917      ((eq (car exp) 'name-url)
 918       (let ((fn (plist-get (nth 1 exp) :feature))
 919             (object (plist-get (nth 1 exp) :object))
 920             domain domain-fn)
 921         (when fn
 922           (setq domain (char-feature-name-domain feature-name))
 923           (when (stringp fn)
 924             (setq fn (intern fn)))
 925           (setq domain-fn (char-feature-name-at-domain fn domain))
 926           (setq feature-name domain-fn)))
 927       (list 'name-url (list :feature feature-name)
 928             (www-uri-make-feature-name-url
 929              (est-object-genre object)
 930              (www-uri-encode-feature-name feature-name)
 931              uri-object))
 932       )
 933      ((eq (car exp) 'domain-name)
 934       (let ((domain (char-feature-name-domain feature-name)))
 935         (if domain
 936             (format "@%s" domain)
 937           ""))
 938       )
 939      ((eq (car exp) 'omitted)
 940       (list 'omitted
 941             (list :object object :feature feature-name)
 942             "...")
 943       )
 944      ((eq (car exp) 'prev-char)
 945       (list 'prev-char
 946             (list :object object :feature feature-name)
 947             '(input (:type "submit" :value "-")))
 948       )
 949      ((eq (car exp) 'next-char)
 950       (list 'next-char
 951             (list :object object :feature feature-name)
 952             '(input (:type "submit" :value "+")))
 953       )
 954      ((eq (car exp) 'link)
 955       (list 'link
 956             (list :ref
 957                   (est-eval-list (plist-get (nth 1 exp) :ref)
 958                                         object feature-name lang uri-object))
 959             (est-eval-list (nthcdr 2 exp)
 960                                   object feature-name lang uri-object))
 961       )
 962      (t
 963       exp)))))
 964
 965 (defun est-eval-list (format-list object feature-name
 966                                   &optional lang uri-object list-props)
 967   (if (consp format-list)
 968       (let ((ret
 969              (mapcar
 970               (lambda (exp)
 971                 (est-eval-unit exp object feature-name lang uri-object nil))
 972               format-list)))
 973         (if (cdr ret)
 974             (list* 'list list-props ret)
 975           (car ret)))
 976     (est-eval-unit format-list object feature-name lang uri-object nil)))
 977
 978
 979 ;;; @ End.
 980 ;;;
 981
 982 (provide 'est-eval)
 983
 984 ;;; est-eval.el ends here