+;; -*- coding: utf-8-mcs-er -*-
+(require 'cwiki-common)
+
+;;; @ Feature value presentation
+;;;
+
+(defun est-eval-value-as-S-exp (value)
+ (list 'S-exp nil (format "%S" value)))
+
+(defun est-eval-value-default (value)
+ (if (listp value)
+ (list* 'list
+ '(:separator " ")
+ (mapcar
+ (lambda (unit)
+ (format "%S" unit))
+ value))
+ (est-eval-value-as-S-exp value)))
+
+(defun est-eval-value-as-object (value)
+ (if (or (characterp value)
+ (concord-object-p value))
+ (list 'object (list :object value)
+ (if (characterp value)
+ (char-to-string value)
+ (let ((genre-o (concord-decode-object
+ '=id (concord-object-genre value)
+ 'genre))
+ format)
+ (or (and genre-o
+ (setq format
+ (concord-object-get
+ genre-o 'object-representative-format))
+ (est-eval-list format value nil))
+ (www-get-feature-value
+ value
+ (or (and genre-o
+ (www-get-feature-value
+ genre-o 'object-representative-feature))
+ 'name))
+ (est-eval-value-default value)))))
+ (est-eval-value-default value)))
+
+(defun est-eval-value-as-HEX (value)
+ (if (integerp value)
+ (list 'HEX nil (format "%X" value))
+ (est-eval-value-as-S-exp value)))
+
+(defun est-eval-value-as-kuten (value)
+ (if (integerp value)
+ (list 'ku-ten
+ nil
+ (format "%02d-%02d"
+ (- (lsh value -8) 32)
+ (- (logand value 255) 32)))
+ (est-eval-value-as-S-exp value)))
+
+(defun est-eval-value-as-kangxi-radical (value)
+ (if (and (integerp value)
+ (<= 0 value)
+ (<= value 214))
+ (list 'kangxi-radical
+ nil
+ (format "%c" (ideographic-radical value)))
+ (est-eval-value-as-S-exp value)))
+
+(defun est-eval-value-as-object-list (value &optional separator)
+ (if (listp value)
+ (list* 'list
+ (if separator
+ (list :separator separator))
+ ;; (mapcar
+ ;; (lambda (unit)
+ ;; (if (characterp unit)
+ ;; (list 'char-link nil (format "%c" unit))
+ ;; (format "%s" unit)))
+ ;; value)
+ (mapcar #'est-eval-value-as-object value)
+ )
+ (format "%s" value)))
+
+(defun est-eval-value-as-ids (value)
+ (if (listp value)
+ (list 'ids nil (ideographic-structure-to-ids value))
+ (format "%s" value)))
+
+(defun est-eval-value-as-space-separated-ids (value)
+ (if (listp value)
+ (list* 'ids
+ '(:separator " ")
+ ;; (mapconcat #'char-to-string
+ ;; (ideographic-structure-to-ids value)
+ ;; " ")
+ (mapcar #'est-eval-value-as-object
+ (ideographic-structure-to-ids value))
+ )
+ (est-eval-value-default value)))
+
+(defun est-eval-value-as-domain-list (value)
+ (if (listp value)
+ (let (source item source-objs source0 start end num)
+ (list* 'res-list
+ '(:separator " ")
+ (mapcar
+ (lambda (unit)
+ (setq unit
+ (if (symbolp unit)
+ (symbol-name unit)
+ (format "%s" unit)))
+ (cond
+ ((string-match "=" unit)
+ (setq source (intern
+ (substring unit 0 (match-beginning 0)))
+ item (car (read-from-string
+ (substring unit (match-end 0)))))
+ (cond
+ ((eq source 'bos)
+ (setq source-objs
+ (list
+ (est-eval-value-as-object
+ (or (concord-decode-object
+ '=id item 'book@ruimoku)
+ (concord-decode-object
+ '=id item 'article@ruimoku)
+ (intern unit)))))
+ )
+ ((eq source 'zob1968)
+ (if (and (symbolp item)
+ (setq num (symbol-name item))
+ (string-match
+ "^\\([0-9]+\\)-\\([0-9]+\\)$" num))
+ (setq start (string-to-number
+ (match-string 1 num))
+ end (string-to-number
+ (match-string 2 num)))
+ (setq start item
+ end item))
+ (if (not (numberp start))
+ (setq source-objs
+ (list
+ (est-eval-value-as-object (intern unit))))
+ (if (eq source source0)
+ (setq source-objs
+ (list
+ (list 'link
+ (list :ref
+ (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
+ start))
+ start)))
+ (setq source0 source)
+ (setq source-objs
+ (list
+ (list 'link
+ (list :ref
+ (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
+ start))
+ start)
+ "="
+ '(link
+ (:ref "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/")
+ "\u4EAC大人\u6587研甲\u9AA8")))
+ )
+ (setq num (1+ start))
+ (while (<= num end)
+ (setq source-objs
+ (cons
+ (list 'link
+ (list :ref
+ (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
+ num))
+ num)
+ source-objs))
+ (setq num (1+ num)))
+ (setq source-objs (nreverse source-objs)))
+ )
+ (t
+ (setq source-objs
+ (list (est-eval-value-as-object (intern unit))))
+ ))
+ (list* 'res-link
+ (list :source source :item item)
+ source-objs)
+ )
+ (t
+ (list 'res-link nil unit)
+ )))
+ value)))
+ (est-eval-value-default value)))
+
+
+;;; @ format evaluator
+;;;
+
+;; (defun est-make-env (object feature-name)
+;; (list (cons 'object object)
+;; (cons 'feature-name feature-name)))
+
+;; (defun est-env-push-item (env item value)
+;; (cons (cons item value)
+;; env))
+
+;; (defun est-env-get-item (env item)
+;; (cdr (assq item env)))
+
+;; (defun est-env-current-value (env)
+;; (let ((obj (est-env-get-item env 'object))
+;; (feature (est-env-get-item env 'feature-name)))
+;; (if (characterp obj)
+;; (char-feature obj feature)
+;; (concord-object-get obj feature))))
+
+
+(defun est-eval-props-to-string (props &optional format)
+ (unless format
+ (setq format (plist-get props :format)))
+ (concat "%"
+ (plist-get props :flag)
+ (if (plist-get props :len)
+ (format "0%d"
+ (let ((ret (plist-get props :len)))
+ (if (stringp ret)
+ (string-to-int ret)
+ ret))))
+ (cond
+ ((eq format 'decimal) "d")
+ ((eq format 'hex) "x")
+ ((eq format 'HEX) "X")
+ ((eq format 'S-exp) "S")
+ (t "s"))))
+
+(defun est-eval-apply-value (object feature-name format props value
+ &optional uri-object)
+ (list 'value
+ (list :object object
+ :feature feature-name)
+ (cond
+ ((memq format '(decimal hex HEX))
+ (if (integerp value)
+ (list format
+ nil
+ (format (est-eval-props-to-string props format)
+ value))
+ (format "%s" value))
+ )
+ ((eq format 'string)
+ (list 'string nil (format "%s" value))
+ )
+ ((eq format 'wiki-text)
+ (est-eval-list value object feature-name nil uri-object)
+ )
+ ((eq format 'S-exp)
+ (est-eval-value-as-S-exp value)
+ )
+ ((eq format 'ku-ten)
+ (est-eval-value-as-kuten value))
+ ((eq format 'kangxi-radical)
+ (est-eval-value-as-kangxi-radical value))
+ ((eq format 'ids)
+ (est-eval-value-as-ids value))
+ ((or (eq format 'space-separated)
+ (eq format 'space-separated-char-list))
+ (est-eval-value-as-object-list value " "))
+ ((eq format 'space-separated-ids)
+ (est-eval-value-as-space-separated-ids value))
+ ((eq format 'space-separated-domain-list)
+ (est-eval-value-as-domain-list value))
+ (t
+ (est-eval-value-default value)
+ ))
+ ))
+
+(defun est-eval-feature-value (object feature-name
+ &optional format lang uri-object value)
+ (unless value
+ (setq value (www-get-feature-value object feature-name)))
+ (unless format
+ (setq format (www-feature-value-format feature-name)))
+ (cond
+ ((symbolp format)
+ (est-eval-apply-value object feature-name
+ format nil value
+ uri-object)
+ )
+ ((consp format)
+ (cond
+ ((null (cdr format))
+ (setq format (car format))
+ (est-eval-apply-value object feature-name
+ (car format) (nth 1 format) value
+ uri-object)
+ )
+ (t
+ (est-eval-list format object feature-name lang uri-object)
+ )))))
+
+(defun est-eval-unit (exp object feature-name
+ &optional lang uri-object value)
+ (unless value
+ (setq value (www-get-feature-value object feature-name)))
+ (unless uri-object
+ (setq uri-object (www-uri-encode-object object)))
+ (cond
+ ((stringp exp) exp)
+ ((or (characterp exp)
+ (concord-object-p exp))
+ (est-eval-value-as-object exp)
+ )
+ ((null exp) "")
+ ((consp exp)
+ (cond
+ ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
+ S-exp string default))
+ (let ((fn (plist-get (nth 1 exp) :feature))
+ domain domain-fn ret)
+ (when fn
+ (when (stringp fn)
+ (setq fn (intern fn)))
+ (setq domain (char-feature-name-domain feature-name))
+ (setq domain-fn (char-feature-name-at-domain fn domain))
+ (if (setq ret (www-get-feature-value object domain-fn))
+ (setq feature-name domain-fn
+ value ret)
+ (setq feature-name fn
+ value (www-get-feature-value object fn)))
+ (push feature-name chise-wiki-displayed-features)
+ ))
+ (if (eq (car exp) 'value)
+ (est-eval-feature-value object feature-name
+ (plist-get (nth 1 exp) :format)
+ lang uri-object value)
+ (est-eval-apply-value
+ object feature-name
+ (car exp) (nth 1 exp) value
+ uri-object))
+ )
+ ((eq (car exp) 'name)
+ (let ((fn (plist-get (nth 1 exp) :feature))
+ domain domain-fn)
+ (when fn
+ (setq domain (char-feature-name-domain feature-name))
+ (when (stringp fn)
+ (setq fn (intern fn)))
+ (setq domain-fn (char-feature-name-at-domain fn domain))
+ (setq feature-name domain-fn)))
+ (list 'feature-name
+ (list :object object
+ :feature feature-name)
+ (www-format-feature-name* feature-name lang))
+ )
+ ((eq (car exp) 'name-url)
+ (let ((fn (plist-get (nth 1 exp) :feature))
+ domain domain-fn)
+ (when fn
+ (setq domain (char-feature-name-domain feature-name))
+ (when (stringp fn)
+ (setq fn (intern fn)))
+ (setq domain-fn (char-feature-name-at-domain fn domain))
+ (setq feature-name domain-fn)))
+ (list 'name-url (list :feature feature-name)
+ (www-uri-make-feature-name-url
+ (www-uri-encode-feature-name feature-name)
+ uri-object))
+ )
+ ((eq (car exp) 'domain-name)
+ (let ((domain (char-feature-name-domain feature-name)))
+ (if domain
+ (format "@%s" domain)
+ ""))
+ )
+ ((eq (car exp) 'prev-char)
+ (list 'prev-char
+ (list :object object :feature feature-name)
+ '(input (:type "submit" :value "-")))
+ )
+ ((eq (car exp) 'next-char)
+ (list 'next-char
+ (list :object object :feature feature-name)
+ '(input (:type "submit" :value "+")))
+ )
+ ((eq (car exp) 'link)
+ (list 'link
+ (list :ref
+ (est-eval-list (plist-get (nth 1 exp) :ref)
+ object feature-name lang uri-object))
+ (est-eval-list (nthcdr 2 exp)
+ object feature-name lang uri-object))
+ )
+ (t
+ exp)))))
+
+(defun est-eval-list (format-list object feature-name
+ &optional lang uri-object)
+ (if (consp format-list)
+ (let ((ret
+ (mapcar
+ (lambda (exp)
+ (est-eval-unit exp object feature-name lang uri-object nil))
+ format-list)))
+ (if (cdr ret)
+ (list* 'list nil ret)
+ (car ret)))
+ (est-eval-unit format-list object feature-name lang uri-object nil)))
+
+
+;;; @ End.
+;;;
+
+(provide 'est-eval)
+
+;;; est-eval.el ends here