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