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