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