From: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
Date: Thu, 9 Dec 2010 00:46:32 +0000 (+0900)
Subject: New files.
X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=064fb21a731624826bc09b70f426f2cf031e7c12;p=chise%2Fest.git

New files.
---

diff --git a/est-eval.el b/est-eval.el
new file mode 100644
index 0000000..65ce97f
--- /dev/null
+++ b/est-eval.el
@@ -0,0 +1,410 @@
+;; -*- 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
diff --git a/est-format.el b/est-format.el
new file mode 100644
index 0000000..c7a7474
--- /dev/null
+++ b/est-format.el
@@ -0,0 +1,178 @@
+;; -*- 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