From: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
Date: Mon, 6 Dec 2010 10:36:28 +0000 (+0900)
Subject: New file.
X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=51d1a2c764d10f4b92eae7e55b402a413de7d39a;p=chise%2Fest.git

New file.
---

diff --git a/cwiki-format.el b/cwiki-format.el
new file mode 100644
index 0000000..45a6984
--- /dev/null
+++ b/cwiki-format.el
@@ -0,0 +1,446 @@
+;; -*- coding: utf-8-mcs-er -*-
+(require 'cwiki-common)
+(require 'est-xml)
+
+;;; @ Feature value presentation
+;;;
+
+(defun www-format-value-as-kuten (value)
+  (format "%02d-%02d"
+	  (- (lsh value -8) 32)
+	  (- (logand value 255) 32)))
+
+(defun www-format-value-default (value &optional without-tags)
+  (if (listp value)
+      (mapconcat
+       (lambda (unit)
+	 (www-format-encode-string
+	  (format "%S" unit)
+	  without-tags))
+       value " ")
+    (www-format-encode-string (format "%S" value) without-tags)))
+  
+(defun www-format-value-as-char-list (value &optional without-tags)
+  (if (listp value)
+      (mapconcat
+       (if without-tags
+	   (lambda (unit)
+	     (www-format-encode-string
+	      (format (if (characterp unit)
+			  "%c"
+			"%s")
+		      unit)
+	      'without-tags))
+	 (let (genre-o name-f ret)
+	   (lambda (unit)
+	     (if (characterp unit)
+		 (format "<a href=\"%s?char=%s\">%s</a>"
+			 chise-wiki-view-url
+			 (www-uri-encode-object unit)
+			 (www-format-encode-string (char-to-string unit)))
+	       (format "<a href=\"%s?%s=%s\">%s</a>"
+		       chise-wiki-view-url
+		       (concord-object-genre unit)
+		       (concord-object-id unit)
+		       (cond
+			((setq ret
+			       (www-get-feature-value
+				unit
+				(setq name-f
+				      (if (setq genre-o
+						(concord-decode-object
+						 '=id
+						 (concord-object-genre unit)
+						 'genre))
+					  (www-get-feature-value
+					   genre-o
+					   'object-representation-format)
+					'name))))
+			 (www-format-eval-feature-value
+			  unit name-f nil nil nil ret
+			  'without-tags 'without-edit)
+			 )
+                        (t
+			 (www-format-encode-string
+			  (format "%S" unit))
+			 ))
+		       unit)))))
+       value " ")
+    (www-format-encode-string (format "%s" value) without-tags)))
+
+(defun www-format-value-as-domain-list (value &optional without-tags)
+  (let (name source0 source num dest rest unit start end ddest)
+    (if (listp value)
+	(if without-tags
+	    (mapconcat
+	     (lambda (unit)
+	       (format "%s" unit))
+	     value " ")
+	  (setq rest value)
+	  (while rest
+	    (setq unit (pop rest))
+	    (if (symbolp unit)
+		(setq name (symbol-name unit)))
+	    (setq dest
+		  (concat
+		   dest
+		   (cond
+		    ((string-match "^zob1968=" name)
+		     (setq source (intern (substring name 0 (match-end 0)))
+			   num (substring name (match-end 0)))
+		     (if (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 (string-to-number num)
+			     end start))
+		     (setq ddest
+			   (if (eq source source0)
+			       (format
+				", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
+				start start)
+			     (setq source0 source)
+			     (format
+			      " <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/\">%s</a>=<a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
+			      (www-format-encode-string "\u4EAC大人\u6587研甲\u9AA8")
+			      start start)))
+		     (setq start (1+ start))
+		     (while (<= start end)
+		       (setq ddest
+			     (concat
+			      ddest
+			      (format
+			       ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
+			       start start)))
+		       (setq start (1+ start)))
+		     ddest)
+		    (t
+		     (setq source unit)
+		     (if (eq source source0)
+			 ""
+		       (setq source0 source)
+		       (concat " " name))
+		     )))))
+	  dest)
+      (www-format-encode-string (format "%s" value) without-tags))))
+
+(defun www-format-value-as-ids (value &optional without-tags)
+  (if (listp value)
+      (mapconcat
+       (if without-tags
+	   (lambda (unit)
+	     (www-format-encode-string
+	      (format (if (characterp unit)
+			  "%c"
+			"%s")
+		      unit)
+	      'without-tags))
+	 (lambda (unit)
+	   (if (characterp unit)
+	       (format "<a href=\"%s?char=%s\">%s</a>"
+		       chise-wiki-view-url
+		       (www-uri-encode-object unit)
+		       (www-format-encode-string (char-to-string unit)))
+	     (www-format-encode-string (format "%s" unit)))))
+       (ideographic-structure-to-ids value) " ")
+    (www-format-encode-string (format "%s" value) without-tags)))
+
+(defun www-format-value-as-S-exp (value &optional without-tags)
+  (www-format-encode-string (format "%S" value) without-tags))
+
+(defun www-format-value-as-HEX (value)
+  (if (integerp value)
+      (format "%X" value)
+    (www-format-value-as-S-exp value)))
+
+(defun www-format-value-as-CCS-default (value)
+  (if (integerp value)
+      (format "0x%s (%d)"
+	      (www-format-value-as-HEX value)
+	      value)
+    (www-format-value-as-S-exp value)))
+
+(defun www-format-value-as-CCS-94x94 (value)
+  (if (integerp value)
+      (format "0x%s [%s] (%d)"
+	      (www-format-value-as-HEX value)
+	      (www-format-value-as-kuten value)
+	      value)
+    (www-format-value-as-S-exp value)))
+
+(defun www-format-value-as-kangxi-radical (value)
+  (if (and (integerp value)
+	   (<= 0 value)
+	   (<= value 214))
+      (www-format-encode-string
+       (format "%c" (ideographic-radical value)))
+    (www-format-value-as-S-exp value)))
+
+(defun www-format-value (object feature-name
+				&optional value format
+				without-tags without-edit)
+  (unless value
+    (setq value (www-get-feature-value object feature-name)))
+  (www-format-apply-value object feature-name
+			  format nil value nil nil
+			  without-tags without-edit)
+  )
+
+
+;;; @ format evaluator
+;;;
+
+(defun www-format-props-to-string (props &optional format)
+  (unless format
+    (setq format (plist-get props :format)))
+  (concat "%"
+	  (plist-get props :flag)
+          ;; (if (plist-get props :zero-padding)
+          ;;     "0")
+	  (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 www-format-apply-value (object feature-name
+				      format props value
+				      &optional uri-object uri-feature
+				      without-tags without-edit)
+  (let (ret)
+    (setq ret
+	  (cond
+	   ((memq format '(decimal hex HEX))
+	    (if (integerp value)
+		(format (www-format-props-to-string props format)
+			value)
+	      (www-format-encode-string
+	       (format "%s" value)
+	       without-tags))
+	    )
+	   ((eq format 'wiki-text)
+	    (if without-tags
+		(www-xml-format-list value)
+	      (www-format-eval-list value object feature-name nil uri-object
+				    without-tags without-edit))
+	    )
+	   ((eq format 'S-exp)
+	    (www-format-encode-string
+	     (format (www-format-props-to-string props format)
+		     value)
+	     without-tags))
+	   ((eq format 'ku-ten)
+	    (www-format-value-as-kuten value))
+	   ((eq format 'kangxi-radical)
+	    (www-format-value-as-kangxi-radical value))
+	   ((eq format 'space-separated-char-list)
+	    (www-format-value-as-char-list value without-tags))
+	   ((eq format 'space-separated-ids)
+	    (www-format-value-as-ids value without-tags))
+	   ((eq format 'space-separated-domain-list)
+	    (www-format-value-as-domain-list value without-tags))
+	   ((eq format 'string)
+	    (www-format-encode-string (format "%s" value) without-tags)
+	    )
+	   (t
+	    (www-format-value-default value without-tags)
+            ))
+	  )
+    (if (or without-tags
+	    without-edit
+	    (eq (plist-get props :mode) 'peek))
+	ret
+      (format "%s <a href=\"%s?%s=%s&feature=%s&format=%s\"
+><input type=\"submit\" value=\"edit\" /></a>"
+	      ret
+	      chise-wiki-edit-url
+	      (est-object-genre object)
+	      uri-object uri-feature format))))
+
+(defun www-format-eval-feature-value (object
+				      feature-name
+				      &optional format lang uri-object value
+				      without-tags without-edit)
+  (unless value
+    (setq value (www-get-feature-value object feature-name)))
+  (unless format
+    (setq format (www-feature-value-format feature-name)))
+  (cond
+   ((symbolp format)
+    (www-format-apply-value
+     object feature-name
+     format nil value
+     uri-object (www-uri-encode-feature-name feature-name)
+     without-tags without-edit)
+    )
+   ((consp format)
+    (cond ((null (cdr format))
+	   (setq format (car format))
+	   (www-format-apply-value
+	    object feature-name
+	    (car format) (nth 1 format) value
+	    uri-object (www-uri-encode-feature-name feature-name)
+	    without-tags without-edit)
+	   )
+	  (t
+	   (www-format-eval-list format object feature-name lang uri-object
+				 without-tags without-edit)
+	   )))))
+
+(defun www-format-eval-unit (exp object feature-name
+				 &optional lang uri-object value
+				 without-tags without-edit)
+  (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) (www-format-encode-string 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)
+	  (www-format-eval-feature-value object feature-name
+					 (plist-get (nth 1 exp) :format)
+					 lang uri-object value
+					 without-tags without-edit)
+	(www-format-apply-value
+	 object feature-name
+	 (car exp) (nth 1 exp) value
+	 uri-object (www-uri-encode-feature-name feature-name)
+	 without-tags without-edit))
+      )
+     ((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)))
+      (if without-tags
+	  (www-format-feature-name feature-name lang)
+	(format "<a href=\"%s\">%s</a>"
+		(www-uri-make-feature-name-url
+		 (www-uri-encode-feature-name feature-name)
+		 uri-object)
+		(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)))
+      (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)
+      (if without-tags
+	  ""
+	(let ((prev-char (find-previous-defined-code-point
+			  feature-name value)))
+	  (if prev-char
+	      (format "\n<a href=\"%s?char=%s\">%s</a>"
+		      chise-wiki-view-url
+		      (www-uri-encode-object prev-char)
+                      "<input type=\"submit\" value=\"-\" />"
+		      ;; (www-format-encode-string
+                      ;;  (char-to-string prev-char))
+		      )
+	    "")))
+      )
+     ((eq (car exp) 'next-char)
+      (if without-tags
+	  ""
+	(let ((next-char (find-next-defined-code-point
+			  feature-name value)))
+	  (if next-char
+	      (format "<a href=\"%s?char=%s\">%s</a>"
+		      chise-wiki-view-url
+		      (www-uri-encode-object next-char)
+                      "<input type=\"submit\" value=\"+\" />"
+		      ;; (www-format-encode-string
+                      ;;  (char-to-string next-char))
+		      )
+	    "")))
+      )
+     ((eq (car exp) 'link)
+      (if without-tags
+	  (www-format-eval-list (nthcdr 2 exp)
+				object feature-name lang uri-object
+				without-tags without-edit)
+	(format "<a
+ href=\"%s\"
+>%s</a
+>"
+		(www-format-eval-list (plist-get (nth 1 exp) :ref)
+				      object feature-name lang uri-object
+				      'without-tags 'without-edit)
+		(www-format-eval-list (nthcdr 2 exp)
+				      object feature-name lang uri-object
+				      without-tags without-edit)))
+      )
+     (t
+      (format "<%s
+>%s</%s
+>"
+	      (car exp)
+	      (www-format-eval-list (nthcdr 2 exp) object feature-name
+				    lang uri-object
+				    without-tags without-edit)
+	      (car exp)))))))
+
+(defun www-format-eval-list (format-list object feature-name
+					 &optional lang uri-object
+					 without-tags without-edit)
+  (if (consp format-list)
+      (mapconcat
+       (lambda (exp)
+	 (www-format-eval-unit exp object feature-name lang uri-object
+			       nil without-tags without-edit))
+       format-list "")
+    (www-format-eval-unit format-list object feature-name lang uri-object
+			  nil without-tags without-edit)))
+
+
+;;; @ End.
+;;;
+
+(provide 'cwiki-format)
+
+;;; cwiki-format.el ends here