est-eval.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'cwiki-common)
   3
   4 (defun ruimoku-format-volume (spec value year lang)
   5   (when (stringp spec)
   6     (setq spec (car (read-from-string spec))))
   7   (cond ((eq spec 'YY) (if (eq lang 'cjk)
   8                                  (format "%d年" year)
   9                                (format "%d" year)))
  10         ((eq spec 00) value)
  11         ((eq spec 01) (concat value "期"))
  12         ((eq spec 02) (concat value "巻"))
  13         ((eq spec 03) (concat value "号"))
  14         ((eq spec 04) (concat value "&GT-35694;"))
  15         ((eq spec 05) (concat value "&GT-33870;"))
  16         ((eq spec 06) (concat value "&GT-56392;"))
  17         ((eq spec 07) (concat value "輯"))
  18         ((eq spec 08) (concat value "&GT-53119;"))
  19         ((eq spec 09) (concat value "&GT-53119;&AJ1-03580;"))
  20         ((eq spec 10) (concat value "冊"))
  21         ((eq spec 11) (concat value "&AJ1-03580;冊"))
  22         ((eq spec 12) (concat value "&J90-3C21;"))
  23         ((eq spec 13) (concat value "&GT-18140;号"))
  24         ((eq spec 14) (concat value "特&GT-56392;号"))
  25         ((eq spec 15) (concat value "本"))
  26         ((eq spec 16) (concat value "&AJ1-03580;"))
  27         ((eq spec 51) (concat "Vol." value))
  28         ((eq spec 52) (concat "No." value))
  29         ((eq spec 53) (concat "Part " value))
  30         ((eq spec 54) (concat "Issue " value))
  31         ((eq spec 55) (concat "Tome " value))
  32         ((eq spec 56) (concat "Tomo " value))
  33         ((eq spec 57) (concat "Tomus " value))
  34         ((eq spec 58) (concat "Fasc." value))
  35         ((eq spec 59) (concat "Livre " value))
  36         ((eq spec 60) (concat "Année " value))
  37         ((eq spec 61) (concat "Bd." value))
  38         ((eq spec 62) (concat "Heft " value))
  39         ((eq spec 63) (concat "Nr." value))
  40         ((eq spec 64) (concat "Jahrg." value))
  41         ((eq spec 65) (concat "Jaarg." value))
  42         ((eq spec 66) (concat "Trimestre" value))
  43         (t "")
  44         ))
  45
  46
  47 ;;; @ Feature value presentation
  48 ;;;
  49
  50 (defun est-eval-value-as-S-exp (value)
  51   (list 'S-exp nil (format "%S" value)))
  52
  53 (defun est-eval-value-default (value)
  54   (if (listp value)
  55       (if (eq (car value) 'omitted)
  56           value
  57         (list* 'list
  58                '(:separator " ")
  59                (mapcar
  60                 (lambda (unit)
  61                   (format "%S" unit))
  62                 value)))
  63     (est-eval-value-as-S-exp value)))
  64
  65 ;; (defun est-journal-volume-object-get-volume-format (spec feature)
  66 ;;   (when (integerp spec)
  67 ;;     (setq spec (format "%02d" spec)))
  68 ;;   (cond ((string= spec "YY") `((decimal (:feature
  69 ;;                                          ->published/date*year)) "年"))
  70 ;;         ((string= spec "00") `((decimal (:feature ,feature))))
  71 ;;         ((string= spec "01") `((decimal (:feature ,feature)) "期"))
  72 ;;         ((string= spec "02") `((decimal (:feature ,feature)) "巻"))
  73 ;;         ((string= spec "03") `((decimal (:feature ,feature)) "号"))
  74 ;;         ((string= spec "04") `((decimal (:feature ,feature)) "&GT-35694;"))
  75 ;;         ((string= spec "05") `((decimal (:feature ,feature)) "&GT-33870;"))
  76 ;;         ((string= spec "06") `((decimal (:feature ,feature)) "&GT-56392;"))
  77 ;;         ((string= spec "07") `((decimal (:feature ,feature)) "輯"))
  78 ;;         ((string= spec "08") `((decimal (:feature ,feature)) "&GT-53119;"))
  79 ;;         ((string= spec "09") `((decimal (:feature ,feature)) "&GT-53119;&AJ1-03580;"))
  80 ;;         ((string= spec "10") `((decimal (:feature ,feature)) "冊"))
  81 ;;         ((string= spec "11") `((decimal (:feature ,feature)) "&AJ1-03580;冊"))
  82 ;;         ((string= spec "12") `((decimal (:feature ,feature)) "&J90-3C21;"))
  83 ;;         ((string= spec "13") `((decimal (:feature ,feature)) "&GT-18140;号"))
  84 ;;         ((string= spec "14") `((decimal (:feature ,feature)) "特&GT-56392;号"))
  85 ;;         ((string= spec "15") `((decimal (:feature ,feature)) "本"))
  86 ;;         ((string= spec "16") `((decimal (:feature ,feature)) "&AJ1-03580;"))
  87 ;;         ((string= spec "51") `("Vol." ((decimal (:feature ,feature)))))
  88 ;;         ((string= spec "52") `("No." ((decimal (:feature ,feature)))))
  89 ;;         ((string= spec "53") `("Part " ((decimal (:feature ,feature)))))
  90 ;;         ((string= spec "54") `("Issue " ((decimal (:feature ,feature)))))
  91 ;;         ((string= spec "55") `("Tome " ((decimal (:feature ,feature)))))
  92 ;;         ((string= spec "56") `("Tomo " ((decimal (:feature ,feature)))))
  93 ;;         ((string= spec "57") `("Tomus " ((decimal (:feature ,feature)))))
  94 ;;         ((string= spec "58") `("Fasc." ((decimal (:feature ,feature)))))
  95 ;;         ((string= spec "59") `("Livre " ((decimal (:feature ,feature)))))
  96 ;;         ((string= spec "60") `("Année " ((decimal (:feature ,feature)))))
  97 ;;         ((string= spec "61") `("Bd." ((decimal (:feature ,feature)))))
  98 ;;         ((string= spec "62") `("Heft " ((decimal (:feature ,feature)))))
  99 ;;         ((string= spec "63") `("Nr." ((decimal (:feature ,feature)))))
 100 ;;         ((string= spec "64") `("Jahrg." ((decimal (:feature ,feature)))))
 101 ;;         ((string= spec "65") `("Jaarg." ((decimal (:feature ,feature)))))
 102 ;;         ((string= spec "66") `("Trimestre" ((decimal (:feature ,feature)))))
 103 ;;         (t nil)
 104 ;;         ))
 105
 106 (defun est-eval-journal-volume (value)
 107   (let ((journal (car (concord-object-get value '<-volume)))
 108         volume-type number-type
 109         year)
 110     (setq volume-type (concord-object-get journal 'volume/type/code)
 111           number-type (concord-object-get journal 'number/type/code))
 112     (setq year (or (concord-object-get value '->published/date*year)
 113                    (concord-object-get
 114                     (car (concord-object-get value 'date)) 'year)))
 115     ;; (append (list (concord-object-get journal 'name))
 116     ;;         (est-journal-volume-object-get-volume-format
 117     ;;          volume-type '<-volume*volume)
 118     ;;         (est-journal-volume-object-get-volume-format
 119     ;;          number-type '<-volume*number)
 120     ;;         )
 121     (concat (concord-object-get journal 'name)
 122             " "
 123             (ruimoku-format-volume
 124              volume-type
 125              (concord-object-get value '<-volume*volume)
 126              year 'cjk)
 127             (ruimoku-format-volume
 128              number-type
 129              (concord-object-get value '<-volume*number)
 130              year 'cjk))
 131     ))
 132
 133 ;; (defun est-eval-creator (value)
 134 ;;   (est-eval-list
 135 ;;    '((value (:feature ->name))
 136 ;;      (string (:feature role*name)))
 137 ;;    value nil))
 138
 139 (defun est-eval-value-as-object (value)
 140   (if (or (characterp value)
 141           (concord-object-p value))
 142       (list 'object (list :object value)
 143             (if (characterp value)
 144                 (char-to-string value)
 145               (let ((genre (concord-object-genre value))
 146                     genre-o
 147                     format)
 148                 (cond
 149                  ((eq genre 'journal-volume@ruimoku)
 150                   ;; (est-eval-list
 151                   ;;  (est-journal-volume-get-object-format value)
 152                   ;;  value nil)
 153                   (est-eval-journal-volume value)
 154                   )
 155                  ;; ((eq genre 'creator@ruimoku)
 156                  ;;  (est-eval-creator value)
 157                  ;;  )
 158                  (t
 159                   (setq genre-o (concord-decode-object '=id genre 'genre))
 160                   (or (and genre-o
 161                            (setq format
 162                                  (concord-object-get
 163                                   genre-o 'object-representative-format))
 164                            (est-eval-list format value nil))
 165                       (www-get-feature-value
 166                        value
 167                        (or (and genre-o
 168                                 (www-get-feature-value
 169                                  genre-o 'object-representative-feature))
 170                            'name))
 171                       (www-get-feature-value value '=name)
 172                       (est-eval-value-default value))
 173                   ))
 174                 )))
 175     (est-eval-value-default value)))
 176
 177 (defun est-eval-value-as-HEX (value)
 178   (if (integerp value)
 179       (list 'HEX nil (format "%X" value))
 180     (est-eval-value-as-S-exp value)))
 181
 182 (defun est-eval-value-as-kuten (value)
 183   (if (integerp value)
 184       (list 'ku-ten
 185             nil
 186             (format "%02d-%02d"
 187                     (- (lsh value -8) 32)
 188                     (- (logand value 255) 32)))
 189     (est-eval-value-as-S-exp value)))
 190
 191 (defun est-eval-value-as-kangxi-radical (value)
 192   (if (and (integerp value)
 193            (<= 0 value)
 194            (<= value 214))
 195       (list 'kangxi-radical
 196             nil
 197             (format "%c" (ideographic-radical value)))
 198     (est-eval-value-as-S-exp value)))
 199
 200 (defun est-eval-value-as-object-list (value &optional separator)
 201   (if (listp value)
 202       (list* 'list
 203              (if separator
 204                  (list :separator separator))
 205              ;; (mapcar
 206              ;;  (lambda (unit)
 207              ;;    (if (characterp unit)
 208              ;;        (list 'char-link nil (format "%c" unit))
 209              ;;      (format "%s" unit)))
 210              ;;  value)
 211              (mapcar #'est-eval-value-as-object value)
 212              )
 213     (format "%s" value)))
 214
 215 (defun est-eval-value-as-ids (value)
 216   (if (listp value)
 217       (list 'ids nil (ideographic-structure-to-ids value))
 218     (format "%s" value)))
 219
 220 (defun est-eval-value-as-space-separated-ids (value)
 221   (if (listp value)
 222       (list* 'ids
 223              '(:separator " ")
 224              ;; (mapconcat #'char-to-string
 225              ;;            (ideographic-structure-to-ids value)
 226              ;;            " ")
 227              (mapcar #'est-eval-value-as-object
 228                      (ideographic-structure-to-ids value))
 229              )
 230     (est-eval-value-default value)))
 231
 232 (defun est-eval-value-as-domain-list (value)
 233   (if (listp value)
 234       (let (source item source-objs source0 start end num)
 235         (list* 'res-list
 236                '(:separator " ")
 237                (mapcar
 238                 (lambda (unit)
 239                   (setq unit
 240                         (if (symbolp unit)
 241                             (symbol-name unit)
 242                           (format "%s" unit)))
 243                   (cond
 244                    ((string-match "=" unit)
 245                     (setq source (intern
 246                                   (substring unit 0 (match-beginning 0)))
 247                           item (car (read-from-string
 248                                      (substring unit (match-end 0)))))
 249                     (cond
 250                      ((eq source 'bos)
 251                       (setq source-objs
 252                             (list
 253                              (est-eval-value-as-object
 254                               (or (concord-decode-object
 255                                    '=id item 'book@ruimoku)
 256                                   (concord-decode-object
 257                                    '=id item 'article@ruimoku)
 258                                   (intern unit)))))
 259                       )
 260                      ((eq source 'zob1968)
 261                       (if (and (symbolp item)
 262                                (setq num (symbol-name item))
 263                                (string-match
 264                                 "^\\([0-9]+\\)-\\([0-9]+\\)$" num))
 265                           (setq start (string-to-number
 266                                        (match-string 1 num))
 267                                 end (string-to-number
 268                                      (match-string 2 num)))
 269                         (setq start item
 270                               end item))
 271                       (if (not (numberp start))
 272                           (setq source-objs
 273                                 (list
 274                                  (est-eval-value-as-object (intern unit))))
 275                         (if (eq source source0)
 276                             (setq source-objs
 277                                   (list
 278                                    (list 'link
 279                                          (list :ref
 280                                                (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 281                                                        start))
 282                                          start)))
 283                           (setq source0 source)
 284                           (setq source-objs
 285                                 (list
 286                                  (list 'link
 287                                        (list :ref
 288                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 289                                                      start))
 290                                        start)
 291                                  "="
 292                                  '(link
 293                                    (:ref "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/")
 294                                    "\u4EAC大人\u6587研甲\u9AA8")))
 295                           )
 296                         (setq num (1+ start))
 297                         (while (<= num end)
 298                           (setq source-objs
 299                                 (cons
 300                                  (list 'link
 301                                        (list :ref
 302                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 303                                                      num))
 304                                        num)
 305                                  source-objs))
 306                           (setq num (1+ num)))
 307                         (setq source-objs (nreverse source-objs)))
 308                       )
 309                      (t
 310                       (setq source-objs
 311                             (list (est-eval-value-as-object (intern unit))))
 312                       ))
 313                     (list* 'res-link
 314                            (list :source source :item item)
 315                            source-objs)
 316                     )
 317                    (t
 318                     (list 'res-link nil unit)
 319                     )))
 320                 value)))
 321     (est-eval-value-default value)))
 322
 323 (defun est-eval-value-as-creators-names (value)
 324   (if (listp value)
 325       (let (role-name)
 326         (list* 'creator-name
 327                '(:separator " ")
 328                (mapcar (lambda (creator)
 329                          (setq role-name
 330                                (concord-object-get creator
 331                                                    'role*name))
 332                          (est-eval-list
 333                           (list
 334                            '(value (:feature ->creator/name))
 335                            (list
 336                             'object (list :object creator)
 337                             (or role-name
 338                                 (format "(%s)"
 339                                         (concord-object-get creator
 340                                                             'role*type)))))
 341                           creator nil)
 342                          )
 343                        value)
 344                ))
 345     (est-eval-value-default value)))
 346
 347 (defun est-eval-value-as-created-works (value)
 348   (if (listp value)
 349       (list* 'creator-name
 350              '(:separator " ")
 351              (mapcar (lambda (creator)
 352                        (est-eval-list
 353                         '((value (:feature <-creator)))
 354                         creator nil))
 355                      value))
 356     (est-eval-value-default value)))
 357
 358
 359 ;;; @ format evaluator
 360 ;;;
 361
 362 ;; (defun est-make-env (object feature-name)
 363 ;;   (list (cons 'object object)
 364 ;;         (cons 'feature-name feature-name)))
 365
 366 ;; (defun est-env-push-item (env item value)
 367 ;;   (cons (cons item value)
 368 ;;         env))
 369
 370 ;; (defun est-env-get-item (env item)
 371 ;;   (cdr (assq item env)))
 372
 373 ;; (defun est-env-current-value (env)
 374 ;;   (let ((obj (est-env-get-item env 'object))
 375 ;;         (feature (est-env-get-item env 'feature-name)))
 376 ;;     (if (characterp obj)
 377 ;;         (char-feature obj feature)
 378 ;;       (concord-object-get obj feature))))
 379
 380
 381 (defun est-eval-props-to-string (props &optional format)
 382   (unless format
 383     (setq format (plist-get props :format)))
 384   (concat "%"
 385           (plist-get props :flag)
 386           (if (plist-get props :len)
 387               (format "0%d"
 388                       (let ((ret (plist-get props :len)))
 389                         (if (stringp ret)
 390                             (string-to-int ret)
 391                           ret))))
 392           (cond
 393            ((eq format 'decimal) "d")
 394            ((eq format 'hex) "x")
 395            ((eq format 'HEX) "X")
 396            ((eq format 'S-exp) "S")
 397            (t "s"))))
 398
 399 (defun est-eval-apply-value (object feature-name format props value
 400                                     &optional uri-object)
 401   (list 'value
 402         (list :object object
 403               :feature feature-name)
 404         (cond
 405          ((memq format '(decimal hex HEX))
 406           (if (integerp value)
 407               (list format
 408                     nil
 409                     (format (est-eval-props-to-string props format)
 410                             value))
 411             (format "%s" value))
 412           )
 413          ((eq format 'string)
 414           (list 'string nil (format "%s" value))
 415           )
 416          ((eq format 'wiki-text)
 417           (est-eval-list value object feature-name nil uri-object)
 418           )
 419          ((eq format 'S-exp)
 420           (est-eval-value-as-S-exp value)
 421           )
 422          ((eq format 'ku-ten)
 423           (est-eval-value-as-kuten value))
 424          ((eq format 'kangxi-radical)
 425           (est-eval-value-as-kangxi-radical value))
 426          ((eq format 'ids)
 427           (est-eval-value-as-ids value))
 428          ((or (eq format 'space-separated)
 429               (eq format 'space-separated-char-list))
 430           (est-eval-value-as-object-list value " "))
 431          ((eq format 'space-separated-ids)
 432           (est-eval-value-as-space-separated-ids value))
 433          ((eq format 'space-separated-domain-list)
 434           (est-eval-value-as-domain-list value))
 435          ((eq format 'space-separated-creator-name-list)
 436           (est-eval-value-as-creators-names value))
 437          ((eq format 'space-separated-created-work-list)
 438           (est-eval-value-as-created-works value))
 439          (t
 440           (est-eval-value-default value)
 441           ))
 442         ))
 443
 444 (defun est-eval-feature-value (object feature-name
 445                                       &optional format lang uri-object value)
 446   (unless value
 447     (setq value (www-get-feature-value object feature-name)))
 448   (unless format
 449     (setq format (www-feature-value-format feature-name)))
 450   (if (consp value)
 451       (let ((ret (condition-case nil
 452                      (nthcdr 127 value)
 453                    (error nil nil))))
 454         (when ret
 455           (setcdr ret
 456                   (list (list 'omitted
 457                               (list :object object :feature feature-name)
 458                               "..."))))))
 459   (cond
 460    ((symbolp format)
 461     (est-eval-apply-value object feature-name
 462                           format nil value
 463                           uri-object)
 464     )
 465    ((consp format)
 466     (cond
 467      ((null (cdr format))
 468       (setq format (car format))
 469       (est-eval-apply-value object feature-name
 470                             (car format) (nth 1 format) value
 471                             uri-object)
 472       )
 473      (t
 474       (est-eval-list format object feature-name lang uri-object)
 475       )))))
 476
 477 (defun est-eval-unit (exp object feature-name
 478                                  &optional lang uri-object value)
 479   (unless value
 480     (setq value (www-get-feature-value object feature-name)))
 481   (unless uri-object
 482     (setq uri-object (www-uri-encode-object object)))
 483   (cond
 484    ((stringp exp) exp)
 485    ((or (characterp exp)
 486         (concord-object-p exp))
 487     (est-eval-value-as-object exp)
 488     )
 489    ((null exp) "")
 490    ((consp exp)
 491     (cond
 492      ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
 493                               S-exp string default))
 494       (let ((fn (plist-get (nth 1 exp) :feature))
 495             domain domain-fn ret)
 496         (when fn
 497           (when (stringp fn)
 498             (setq fn (intern fn)))
 499           (setq domain (char-feature-name-domain feature-name))
 500           (setq domain-fn (char-feature-name-at-domain fn domain))
 501           (if (setq ret (www-get-feature-value object domain-fn))
 502               (setq feature-name domain-fn
 503                     value ret)
 504             (setq feature-name fn
 505                   value (www-get-feature-value object fn)))
 506           (push feature-name chise-wiki-displayed-features)
 507           ))
 508       (if (eq (car exp) 'value)
 509           (est-eval-feature-value object feature-name
 510                                          (plist-get (nth 1 exp) :format)
 511                                          lang uri-object value)
 512         (est-eval-apply-value
 513          object feature-name
 514          (car exp) (nth 1 exp) value
 515          uri-object))
 516       )
 517      ((eq (car exp) 'name)
 518       (let ((fn (plist-get (nth 1 exp) :feature))
 519             domain domain-fn)
 520         (when fn
 521           (setq domain (char-feature-name-domain feature-name))
 522           (when (stringp fn)
 523             (setq fn (intern fn)))
 524           (setq domain-fn (char-feature-name-at-domain fn domain))
 525           (setq feature-name domain-fn)))
 526       (list 'feature-name
 527             (list :object object
 528                   :feature feature-name)
 529             (www-format-feature-name* feature-name lang))
 530       )
 531      ((eq (car exp) 'name-url)
 532       (let ((fn (plist-get (nth 1 exp) :feature))
 533             (object (plist-get (nth 1 exp) :object))
 534             domain domain-fn)
 535         (when fn
 536           (setq domain (char-feature-name-domain feature-name))
 537           (when (stringp fn)
 538             (setq fn (intern fn)))
 539           (setq domain-fn (char-feature-name-at-domain fn domain))
 540           (setq feature-name domain-fn)))
 541       (list 'name-url (list :feature feature-name)
 542             (www-uri-make-feature-name-url
 543              (est-object-genre object)
 544              (www-uri-encode-feature-name feature-name)
 545              uri-object))
 546       )
 547      ((eq (car exp) 'domain-name)
 548       (let ((domain (char-feature-name-domain feature-name)))
 549         (if domain
 550             (format "@%s" domain)
 551           ""))
 552       )
 553      ((eq (car exp) 'omitted)
 554       (list 'omitted
 555             (list :object object :feature feature-name)
 556             "...")
 557       )
 558      ((eq (car exp) 'prev-char)
 559       (list 'prev-char
 560             (list :object object :feature feature-name)
 561             '(input (:type "submit" :value "-")))
 562       )
 563      ((eq (car exp) 'next-char)
 564       (list 'next-char
 565             (list :object object :feature feature-name)
 566             '(input (:type "submit" :value "+")))
 567       )
 568      ((eq (car exp) 'link)
 569       (list 'link
 570             (list :ref
 571                   (est-eval-list (plist-get (nth 1 exp) :ref)
 572                                         object feature-name lang uri-object))
 573             (est-eval-list (nthcdr 2 exp)
 574                                   object feature-name lang uri-object))
 575       )
 576      (t
 577       exp)))))
 578
 579 (defun est-eval-list (format-list object feature-name
 580                                   &optional lang uri-object)
 581   (if (consp format-list)
 582       (let ((ret
 583              (mapcar
 584               (lambda (exp)
 585                 (est-eval-unit exp object feature-name lang uri-object nil))
 586               format-list)))
 587         (if (cdr ret)
 588             (list* 'list nil ret)
 589           (car ret)))
 590     (est-eval-unit format-list object feature-name lang uri-object nil)))
 591
 592
 593 ;;; @ End.
 594 ;;;
 595
 596 (provide 'est-eval)
 597
 598 ;;; est-eval.el ends here