--- /dev/null
+;; -*- 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
--- /dev/null
+;; -*- coding: utf-8-mcs-er -*-
+(require 'cwiki-common)
+
+
+;;; @ XML generator
+;;;
+
+(defun est-format-props (props)
+ (let ((dest "")
+ key val)
+ (while props
+ (setq key (pop props)
+ val (pop props))
+ (if (symbolp key)
+ (setq key (symbol-name key)))
+ (if (eq (aref key 0) ?:)
+ (setq key (substring key 1)))
+ (setq dest
+ (format "%s %s=\"%s\""
+ dest key
+ (www-format-encode-string
+ (format "%s"
+ (est-format-unit val 'without-tags
+ 'without-edit 'as-property))
+ 'without-tags))))
+ dest))
+
+(defun est-format-unit (format-unit
+ &optional without-tags without-edit as-property
+ separator)
+ (let (name props children ret object feature format value)
+ (cond
+ ((stringp format-unit)
+ (www-format-encode-string format-unit without-tags (not as-property))
+ )
+ ((consp format-unit)
+ (setq name (car format-unit)
+ props (nth 1 format-unit)
+ children (nthcdr 2 format-unit))
+ (cond
+ ((eq name 'object)
+ (setq name 'span)
+ (unless without-tags
+ (when (setq object (plist-get props :object))
+ (setq children
+ (list
+ (list* 'a
+ (list :href (www-uri-make-object-url object))
+ children)))))
+ )
+ ((eq name 'prev-char)
+ (when (and (not without-tags)
+ (setq object (plist-get props :object))
+ (setq feature (plist-get props :feature))
+ (setq value (www-get-feature-value object feature))
+ (setq ret (find-previous-defined-code-point feature value)))
+ (setq children
+ (list
+ (list* 'a
+ (list :href (www-uri-make-object-url ret))
+ children))))
+ )
+ ((eq name 'next-char)
+ (when (and (not without-tags)
+ (setq object (plist-get props :object))
+ (setq feature (plist-get props :feature))
+ (setq value (www-get-feature-value object feature))
+ (setq ret (find-next-defined-code-point feature value)))
+ (setq children
+ (list
+ (list* 'a
+ (list :href (www-uri-make-object-url ret))
+ children))))
+ )
+ ((eq name 'feature-name)
+ (setq name 'span)
+ (unless without-tags
+ (when (and (setq object (plist-get props :object))
+ (setq feature (plist-get props :feature)))
+ (setq children
+ (list
+ (list* 'a
+ (list :href
+ (www-uri-make-feature-name-url
+ (www-uri-encode-feature-name feature)
+ (www-uri-encode-object object)))
+ children)))))
+ )
+ ((eq name 'value)
+ (setq format
+ (if (consp (car children))
+ (caar children)))
+ (unless without-edit
+ (setq children
+ (append children
+ (list (list 'edit-value
+ (if format
+ (list* :format format props)
+ props)
+ '(input
+ (:type "submit" :value "edit")))))))
+ (unless without-tags
+ (setq name 'span
+ props (list* :class "value" props)))
+ )
+ ((eq name 'link)
+ (setq ret (plist-get props :ref))
+ ;; (unless (stringp ret)
+ ;; (setq props (plist-remprop (copy-list props) :ref))
+ ;; (setq children
+ ;; (cons (list 'ref nil ret)
+ ;; children)))
+ (unless without-tags
+ (setq name 'a
+ props (list* :href ret
+ (plist-remprop (copy-list props) :ref))))
+ )
+ ((and (eq name 'edit-value)
+ (setq object (plist-get props :object))
+ (setq feature (plist-get props :feature)))
+ (setq format (or (plist-get props :format) 'default))
+ (setq name 'a
+ props (list :href (format "%s?%s=%s&feature=%s&format=%s"
+ chise-wiki-edit-url
+ (est-object-genre object)
+ (www-uri-encode-object object)
+ (www-uri-encode-feature-name feature)
+ format)))
+ )
+ ((memq name '(div
+ a ul ol p
+ span
+ input))
+ )
+ (t
+ (unless without-tags
+ (setq props (list* :class name props)
+ name 'span))
+ ))
+ (unless separator
+ (setq separator (plist-get props :separator)))
+ (if children
+ (if without-tags
+ (est-format-list children without-tags as-property separator)
+ (format "<%s%s>%s</%s>"
+ name
+ (if props
+ (est-format-props props)
+ "")
+ (est-format-list
+ children nil without-edit as-property separator)
+ name))
+ (if without-tags
+ ""
+ (format "<%s%s/>"
+ name (est-format-props props))))
+ )
+ (t
+ (format "%s" format-unit)))))
+
+(defun est-format-list (format-list
+ &optional without-tags without-edit as-property
+ separator)
+ (if (atom format-list)
+ (est-format-unit
+ format-list without-tags without-edit as-property separator)
+ (mapconcat (lambda (unit)
+ (est-format-unit
+ unit without-tags without-edit as-property separator))
+ format-list separator)))
+
+
+;;; @ End.
+;;;
+
+(provide 'est-format)
+
+;;; est-format.el ends here
projects / chise / est.git / commitdiff