est-eval.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'cwiki-common)
   3
   4 ;;; @ Feature value presentation
   5 ;;;
   6
   7 (defun est-eval-value-as-S-exp (value)
   8   (list 'S-exp nil (format "%S" value)))
   9
  10 (defun est-eval-value-default (value)
  11   (if (listp value)
  12       (if (eq (car value) 'omitted)
  13           value
  14         (list* 'list
  15                '(:separator " ")
  16                (mapcar
  17                 (lambda (unit)
  18                   (format "%S" unit))
  19                 value)))
  20     (est-eval-value-as-S-exp value)))
  21
  22 (defun est-eval-value-as-object (value)
  23   (if (or (characterp value)
  24           (concord-object-p value))
  25       (list 'object (list :object value)
  26             (if (characterp value)
  27                 (char-to-string value)
  28               (let ((genre-o (concord-decode-object
  29                               '=id (concord-object-genre value)
  30                               'genre))
  31                     format)
  32                 (or (and genre-o
  33                          (setq format
  34                                (concord-object-get
  35                                 genre-o 'object-representative-format))
  36                          (est-eval-list format value nil))
  37                     (www-get-feature-value
  38                      value
  39                      (or (and genre-o
  40                               (www-get-feature-value
  41                                genre-o 'object-representative-feature))
  42                          'name))
  43                     (est-eval-value-default value)))))
  44     (est-eval-value-default value)))
  45
  46 (defun est-eval-value-as-HEX (value)
  47   (if (integerp value)
  48       (list 'HEX nil (format "%X" value))
  49     (est-eval-value-as-S-exp value)))
  50
  51 (defun est-eval-value-as-kuten (value)
  52   (if (integerp value)
  53       (list 'ku-ten
  54             nil
  55             (format "%02d-%02d"
  56                     (- (lsh value -8) 32)
  57                     (- (logand value 255) 32)))
  58     (est-eval-value-as-S-exp value)))
  59
  60 (defun est-eval-value-as-kangxi-radical (value)
  61   (if (and (integerp value)
  62            (<= 0 value)
  63            (<= value 214))
  64       (list 'kangxi-radical
  65             nil
  66             (format "%c" (ideographic-radical value)))
  67     (est-eval-value-as-S-exp value)))
  68
  69 (defun est-eval-value-as-object-list (value &optional separator)
  70   (if (listp value)
  71       (list* 'list
  72              (if separator
  73                  (list :separator separator))
  74              ;; (mapcar
  75              ;;  (lambda (unit)
  76              ;;    (if (characterp unit)
  77              ;;        (list 'char-link nil (format "%c" unit))
  78              ;;      (format "%s" unit)))
  79              ;;  value)
  80              (mapcar #'est-eval-value-as-object value)
  81              )
  82     (format "%s" value)))
  83
  84 (defun est-eval-value-as-ids (value)
  85   (if (listp value)
  86       (list 'ids nil (ideographic-structure-to-ids value))
  87     (format "%s" value)))
  88
  89 (defun est-eval-value-as-space-separated-ids (value)
  90   (if (listp value)
  91       (list* 'ids
  92              '(:separator " ")
  93              ;; (mapconcat #'char-to-string
  94              ;;            (ideographic-structure-to-ids value)
  95              ;;            " ")
  96              (mapcar #'est-eval-value-as-object
  97                      (ideographic-structure-to-ids value))
  98              )
  99     (est-eval-value-default value)))
 100
 101 (defun est-eval-value-as-domain-list (value)
 102   (if (listp value)
 103       (let (source item source-objs source0 start end num)
 104         (list* 'res-list
 105                '(:separator " ")
 106                (mapcar
 107                 (lambda (unit)
 108                   (setq unit
 109                         (if (symbolp unit)
 110                             (symbol-name unit)
 111                           (format "%s" unit)))
 112                   (cond
 113                    ((string-match "=" unit)
 114                     (setq source (intern
 115                                   (substring unit 0 (match-beginning 0)))
 116                           item (car (read-from-string
 117                                      (substring unit (match-end 0)))))
 118                     (cond
 119                      ((eq source 'bos)
 120                       (setq source-objs
 121                             (list
 122                              (est-eval-value-as-object
 123                               (or (concord-decode-object
 124                                    '=id item 'book@ruimoku)
 125                                   (concord-decode-object
 126                                    '=id item 'article@ruimoku)
 127                                   (intern unit)))))
 128                       )
 129                      ((eq source 'zob1968)
 130                       (if (and (symbolp item)
 131                                (setq num (symbol-name item))
 132                                (string-match
 133                                 "^\\([0-9]+\\)-\\([0-9]+\\)$" num))
 134                           (setq start (string-to-number
 135                                        (match-string 1 num))
 136                                 end (string-to-number
 137                                      (match-string 2 num)))
 138                         (setq start item
 139                               end item))
 140                       (if (not (numberp start))
 141                           (setq source-objs
 142                                 (list
 143                                  (est-eval-value-as-object (intern unit))))
 144                         (if (eq source source0)
 145                             (setq source-objs
 146                                   (list
 147                                    (list 'link
 148                                          (list :ref
 149                                                (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 150                                                        start))
 151                                          start)))
 152                           (setq source0 source)
 153                           (setq source-objs
 154                                 (list
 155                                  (list 'link
 156                                        (list :ref
 157                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 158                                                      start))
 159                                        start)
 160                                  "="
 161                                  '(link
 162                                    (:ref "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/")
 163                                    "\u4EAC大人\u6587研甲\u9AA8")))
 164                           )
 165                         (setq num (1+ start))
 166                         (while (<= num end)
 167                           (setq source-objs
 168                                 (cons
 169                                  (list 'link
 170                                        (list :ref
 171                                              (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
 172                                                      num))
 173                                        num)
 174                                  source-objs))
 175                           (setq num (1+ num)))
 176                         (setq source-objs (nreverse source-objs)))
 177                       )
 178                      (t
 179                       (setq source-objs
 180                             (list (est-eval-value-as-object (intern unit))))
 181                       ))
 182                     (list* 'res-link
 183                            (list :source source :item item)
 184                            source-objs)
 185                     )
 186                    (t
 187                     (list 'res-link nil unit)
 188                     )))
 189                 value)))
 190     (est-eval-value-default value)))
 191
 192
 193 ;;; @ format evaluator
 194 ;;;
 195
 196 ;; (defun est-make-env (object feature-name)
 197 ;;   (list (cons 'object object)
 198 ;;         (cons 'feature-name feature-name)))
 199
 200 ;; (defun est-env-push-item (env item value)
 201 ;;   (cons (cons item value)
 202 ;;         env))
 203
 204 ;; (defun est-env-get-item (env item)
 205 ;;   (cdr (assq item env)))
 206
 207 ;; (defun est-env-current-value (env)
 208 ;;   (let ((obj (est-env-get-item env 'object))
 209 ;;         (feature (est-env-get-item env 'feature-name)))
 210 ;;     (if (characterp obj)
 211 ;;         (char-feature obj feature)
 212 ;;       (concord-object-get obj feature))))
 213
 214
 215 (defun est-eval-props-to-string (props &optional format)
 216   (unless format
 217     (setq format (plist-get props :format)))
 218   (concat "%"
 219           (plist-get props :flag)
 220           (if (plist-get props :len)
 221               (format "0%d"
 222                       (let ((ret (plist-get props :len)))
 223                         (if (stringp ret)
 224                             (string-to-int ret)
 225                           ret))))
 226           (cond
 227            ((eq format 'decimal) "d")
 228            ((eq format 'hex) "x")
 229            ((eq format 'HEX) "X")
 230            ((eq format 'S-exp) "S")
 231            (t "s"))))
 232
 233 (defun est-eval-apply-value (object feature-name format props value
 234                                     &optional uri-object)
 235   (list 'value
 236         (list :object object
 237               :feature feature-name)
 238         (cond
 239          ((memq format '(decimal hex HEX))
 240           (if (integerp value)
 241               (list format
 242                     nil
 243                     (format (est-eval-props-to-string props format)
 244                             value))
 245             (format "%s" value))
 246           )
 247          ((eq format 'string)
 248           (list 'string nil (format "%s" value))
 249           )
 250          ((eq format 'wiki-text)
 251           (est-eval-list value object feature-name nil uri-object)
 252           )
 253          ((eq format 'S-exp)
 254           (est-eval-value-as-S-exp value)
 255           )
 256          ((eq format 'ku-ten)
 257           (est-eval-value-as-kuten value))
 258          ((eq format 'kangxi-radical)
 259           (est-eval-value-as-kangxi-radical value))
 260          ((eq format 'ids)
 261           (est-eval-value-as-ids value))
 262          ((or (eq format 'space-separated)
 263               (eq format 'space-separated-char-list))
 264           (est-eval-value-as-object-list value " "))
 265          ((eq format 'space-separated-ids)
 266           (est-eval-value-as-space-separated-ids value))
 267          ((eq format 'space-separated-domain-list)
 268           (est-eval-value-as-domain-list value))
 269          (t
 270           (est-eval-value-default value)
 271           ))
 272         ))
 273
 274 (defun est-eval-feature-value (object feature-name
 275                                       &optional format lang uri-object value)
 276   (unless value
 277     (setq value (www-get-feature-value object feature-name)))
 278   (unless format
 279     (setq format (www-feature-value-format feature-name)))
 280   (if (consp value)
 281       (let ((ret (condition-case nil
 282                      (nthcdr 127 value)
 283                    (error nil nil))))
 284         (when ret
 285           (setcdr ret
 286                   (list (list 'omitted
 287                               (list :object object :feature feature-name)
 288                               "..."))))))
 289   (cond
 290    ((symbolp format)
 291     (est-eval-apply-value object feature-name
 292                           format nil value
 293                           uri-object)
 294     )
 295    ((consp format)
 296     (cond
 297      ((null (cdr format))
 298       (setq format (car format))
 299       (est-eval-apply-value object feature-name
 300                             (car format) (nth 1 format) value
 301                             uri-object)
 302       )
 303      (t
 304       (est-eval-list format object feature-name lang uri-object)
 305       )))))
 306
 307 (defun est-eval-unit (exp object feature-name
 308                                  &optional lang uri-object value)
 309   (unless value
 310     (setq value (www-get-feature-value object feature-name)))
 311   (unless uri-object
 312     (setq uri-object (www-uri-encode-object object)))
 313   (cond
 314    ((stringp exp) exp)
 315    ((or (characterp exp)
 316         (concord-object-p exp))
 317     (est-eval-value-as-object exp)
 318     )
 319    ((null exp) "")
 320    ((consp exp)
 321     (cond
 322      ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
 323                               S-exp string default))
 324       (let ((fn (plist-get (nth 1 exp) :feature))
 325             domain domain-fn ret)
 326         (when fn
 327           (when (stringp fn)
 328             (setq fn (intern fn)))
 329           (setq domain (char-feature-name-domain feature-name))
 330           (setq domain-fn (char-feature-name-at-domain fn domain))
 331           (if (setq ret (www-get-feature-value object domain-fn))
 332               (setq feature-name domain-fn
 333                     value ret)
 334             (setq feature-name fn
 335                   value (www-get-feature-value object fn)))
 336           (push feature-name chise-wiki-displayed-features)
 337           ))
 338       (if (eq (car exp) 'value)
 339           (est-eval-feature-value object feature-name
 340                                          (plist-get (nth 1 exp) :format)
 341                                          lang uri-object value)
 342         (est-eval-apply-value
 343          object feature-name
 344          (car exp) (nth 1 exp) value
 345          uri-object))
 346       )
 347      ((eq (car exp) 'name)
 348       (let ((fn (plist-get (nth 1 exp) :feature))
 349             domain domain-fn)
 350         (when fn
 351           (setq domain (char-feature-name-domain feature-name))
 352           (when (stringp fn)
 353             (setq fn (intern fn)))
 354           (setq domain-fn (char-feature-name-at-domain fn domain))
 355           (setq feature-name domain-fn)))
 356       (list 'feature-name
 357             (list :object object
 358                   :feature feature-name)
 359             (www-format-feature-name* feature-name lang))
 360       )
 361      ((eq (car exp) 'name-url)
 362       (let ((fn (plist-get (nth 1 exp) :feature))
 363             (object (plist-get (nth 1 exp) :object))
 364             domain domain-fn)
 365         (when fn
 366           (setq domain (char-feature-name-domain feature-name))
 367           (when (stringp fn)
 368             (setq fn (intern fn)))
 369           (setq domain-fn (char-feature-name-at-domain fn domain))
 370           (setq feature-name domain-fn)))
 371       (list 'name-url (list :feature feature-name)
 372             (www-uri-make-feature-name-url
 373              (est-object-genre object)
 374              (www-uri-encode-feature-name feature-name)
 375              uri-object))
 376       )
 377      ((eq (car exp) 'domain-name)
 378       (let ((domain (char-feature-name-domain feature-name)))
 379         (if domain
 380             (format "@%s" domain)
 381           ""))
 382       )
 383      ((eq (car exp) 'omitted)
 384       (list 'omitted
 385             (list :object object :feature feature-name)
 386             "...")
 387       )
 388      ((eq (car exp) 'prev-char)
 389       (list 'prev-char
 390             (list :object object :feature feature-name)
 391             '(input (:type "submit" :value "-")))
 392       )
 393      ((eq (car exp) 'next-char)
 394       (list 'next-char
 395             (list :object object :feature feature-name)
 396             '(input (:type "submit" :value "+")))
 397       )
 398      ((eq (car exp) 'link)
 399       (list 'link
 400             (list :ref
 401                   (est-eval-list (plist-get (nth 1 exp) :ref)
 402                                         object feature-name lang uri-object))
 403             (est-eval-list (nthcdr 2 exp)
 404                                   object feature-name lang uri-object))
 405       )
 406      (t
 407       exp)))))
 408
 409 (defun est-eval-list (format-list object feature-name
 410                                   &optional lang uri-object)
 411   (if (consp format-list)
 412       (let ((ret
 413              (mapcar
 414               (lambda (exp)
 415                 (est-eval-unit exp object feature-name lang uri-object nil))
 416               format-list)))
 417         (if (cdr ret)
 418             (list* 'list nil ret)
 419           (car ret)))
 420     (est-eval-unit format-list object feature-name lang uri-object nil)))
 421
 422
 423 ;;; @ End.
 424 ;;;
 425
 426 (provide 'est-eval)
 427
 428 ;;; est-eval.el ends here