;; -*- coding: utf-8-mcs-er -*-
(require 'char-db-util)

(setq file-name-coding-system 'utf-8-mcs-er)


(concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db")

(concord-assign-genre 'journal-volume@ruimoku "/usr/local/var/ruimoku/db")
(concord-assign-genre 'article@ruimoku "/usr/local/var/ruimoku/db")
(concord-assign-genre 'book@ruimoku "/usr/local/var/ruimoku/db")

(concord-assign-genre 'classification@ruimoku "/usr/local/var/ruimoku/db")
(concord-assign-genre 'region@ruimoku "/usr/local/var/ruimoku/db")
(concord-assign-genre 'era@ruimoku "/usr/local/var/ruimoku/db")
(concord-assign-genre 'period@ruimoku "/usr/local/var/ruimoku/db")
(concord-assign-genre 'journal@ruimoku "/usr/local/var/ruimoku/db")


(defvar chise-wiki-view-url "view.cgi")
(defvar chise-wiki-edit-url "edit.cgi")

(defvar chise-wiki-bitmap-glyphs-url
  "http://chise.zinbun.kyoto-u.ac.jp/glyphs")

(defvar chise-wiki-glyph-cgi-url
  "http://chise.zinbun.kyoto-u.ac.jp/chisewiki/glyph.cgi")

(defvar chise-wiki-displayed-features nil)

(defun decode-uri-string (string &optional coding-system)
  (if (> (length string) 0)
      (let ((i 0)
	    dest)
	(setq string
	      (mapconcat (lambda (char)
			   (if (eq char ?+)
			       " "
			     (char-to-string char)))
			 string ""))
	(while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
	  (setq dest (concat dest
			     (substring string i (match-beginning 0))
			     (char-to-string
			      (int-char
			       (string-to-int (match-string 1 string) 16))))
		i (match-end 0)))
	(decode-coding-string
	 (concat dest (substring string i))
	 coding-system))))

(defun www-feature-type (feature-name)
  (or (char-feature-property feature-name 'type)
      (let ((str (symbol-name feature-name)))
	(cond
	 ((string-match "\\*note\\(@[^*]+\\)?$" str)
	  'stext)
	 ((string-match "\\*sources\\(@[^*]+\\)?$" str)
	  'domain-list)
	 ((string-match "\\*" str)
	  nil)
	 ((string-match "^\\(->\\|<-\\)" str)
	  'relation)
	 ((string-match "^ideographic-structure\\(@\\|$\\)" str)
	  'structure)
	 ))))

(defun www-feature-format (feature-name)
  (or (char-feature-property feature-name 'format)
      (let (fn parent ret)
	(setq fn feature-name)
	(while (and (setq parent (char-feature-name-parent fn))
		    (null (setq ret
				(char-feature-property
				 parent 'format))))
	  (setq fn parent))
	ret)
      '((name) " : " (value))))

(defun www-feature-value-format (feature-name)
  (or (char-feature-property feature-name 'value-format)
      (let (fn parent ret)
	(setq fn feature-name)
	(while (and (setq parent (char-feature-name-parent fn))
		    (null (setq ret
				(char-feature-property
				 parent 'value-format))))
	  (setq fn parent))
	ret)
      (let ((type (www-feature-type feature-name)))
	(cond ((eq type 'relation)
	       'space-separated-char-list)
	      ((eq type 'structure)
	       'space-separated-ids)
	      ((eq type 'stext)
	       'wiki-text)
	      ))
      (if (find-charset feature-name)
	  (if (and (= (charset-dimension feature-name) 2)
		   (= (charset-chars feature-name) 94))
	      '("0x" (HEX)
		" (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
	    '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))))

(defun char-feature-name-at-domain (feature-name domain)
  (if domain
      (let ((name (symbol-name feature-name)))
	(cond
	 ((string-match "@[^*]+$" name)
	  (intern (format "%s/%s" name domain))
	  )
	 (t
	  (intern (format "%s@%s" name domain))
	  )))
    feature-name))

(defun char-feature-name-parent (feature-name)
  (let ((name (symbol-name feature-name)))
    (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
	(intern (substring name 0 (car (last (match-data) 2)))))))

(defun char-feature-name-domain (feature-name)
  (let ((name (symbol-name feature-name)))
    (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
	(intern (substring name (1+ (match-beginning 0)))))))

(defun char-feature-name-sans-versions (feature)
  (let ((feature-name (symbol-name feature)))
    (if (string-match "[@/]\\$rev=latest$" feature-name)
	(intern (substring feature-name 0 (match-beginning 0)))
      feature)))

(defun www-get-feature-value (object feature)
  (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
    (cond
     ((characterp object)
      (mount-char-attribute-table latest-feature)
      (or (char-feature object latest-feature)
	  (char-feature object feature))
      )
     (t
      (or (concord-object-get object latest-feature)
	  (concord-object-get object feature))
      ))))

(defun get-previous-code-point (ccs code)
  (let ((chars (charset-chars ccs))
	(dim (charset-dimension ccs))
	(i 0)
	mask byte-min byte-max
	bytes dest)
    (cond
     ((= chars 94)
      (setq mask #x7F
	    byte-min 33
	    byte-max 126)
      )
     ((= chars 96)
      (setq mask #x7F
	    byte-min 32
	    byte-max 127)
      )
     ((= chars 128)
      (setq mask #x7F
	    byte-min 0
	    byte-max #xFF)
      )
     (t ; (= chars 256)
      (setq mask #xFF
	    byte-min 0
	    byte-max #xFF)
      ))
    (setq bytes (make-vector dim 0))
    (while (< i dim)
      (aset bytes i (logand (lsh code (* i -8)) mask))
      (setq i (1+ i)))
    (setq i 0)
    (while (and (< i dim)
		(progn
		  (aset bytes i (1- (aref bytes i)))
		  (< (aref bytes i) byte-min)))
      (aset bytes i byte-max)
      (setq i (1+ i)))
    (when (< i dim)
      (setq dest (aref bytes 0)
	    i 1)
      (while (< i dim)
	(setq dest (logior dest (lsh (aref bytes i) (* i 8)))
	      i (1+ i)))
      dest)))

(defun get-next-code-point (ccs code)
  (let ((chars (charset-chars ccs))
	(dim (charset-dimension ccs))
	(i 0)
	mask byte-min byte-max
	bytes dest)
    (cond
     ((= chars 94)
      (setq mask #x7F
	    byte-min 33
	    byte-max 126)
      )
     ((= chars 96)
      (setq mask #x7F
	    byte-min 32
	    byte-max 127)
      )
     ((= chars 128)
      (setq mask #x7F
	    byte-min 0
	    byte-max #xFF)
      )
     (t ; (= chars 256)
      (setq mask #xFF
	    byte-min 0
	    byte-max #xFF)
      ))
    (setq bytes (make-vector dim 0))
    (while (< i dim)
      (aset bytes i (logand (lsh code (* i -8)) mask))
      (setq i (1+ i)))
    (setq i 0)
    (while (and (< i dim)
		(progn
		  (aset bytes i (1+ (aref bytes i)))
		  (> (aref bytes i) byte-max)))
      (aset bytes i byte-min)
      (setq i (1+ i)))
    (when (< i dim)
      (setq dest (aref bytes 0)
	    i 1)
      (while (< i dim)
	(setq dest (logior dest (lsh (aref bytes i) (* i 8)))
	      i (1+ i)))
      dest)))

(defun find-previous-defined-code-point (ccs code)
  (let ((i (get-previous-code-point ccs code))
	char)
    (cond
     ((eq ccs '=jis-x0208)
      (setq ccs '=jis-x0208@1990))
     ((eq ccs '=jis-x0213-1)
      (setq ccs '=jis-x0213-1@2004)))
    (while (and i
		(>= i 0)
		(null (setq char (decode-char ccs i
					      (unless (eq ccs '=ucs)
						'defined-only)))))
      (setq i (get-previous-code-point ccs i)))
    char))

(defun find-next-defined-code-point (ccs code)
  (let ((i (get-next-code-point ccs code))
	max char)
    (setq max (+ code 1000))
    (cond
     ((eq ccs '=jis-x0208)
      (setq ccs '=jis-x0208@1990))
     ((eq ccs '=jis-x0213-1)
      (setq ccs '=jis-x0213-1@2004)))
    (while (and i
		(<= i max)
		(null (setq char (decode-char ccs i
					      (unless (eq ccs '=ucs)
						'defined-only)))))
      (setq i (get-next-code-point ccs i)))
    char))


;;; @ URI representation
;;;

(defun www-uri-decode-feature-name (uri-feature)
  (let (feature)
    (cond
     ((string-match "^from\\." uri-feature)
      (intern (format "<-%s" (substring uri-feature (match-end 0))))
      )
     ((string-match "^to\\." uri-feature)
      (intern (format "->%s" (substring uri-feature (match-end 0))))
      )
     ((string-match "^rep\\." uri-feature)
      (intern (format "=%s" (substring uri-feature (match-end 0))))
      )
     ((string-match "^g\\." uri-feature)
      (intern (format "=>>%s" (substring uri-feature (match-end 0))))
      )
     ((string-match "^gi\\." uri-feature)
      (intern (format "=>>>%s" (substring uri-feature (match-end 0))))
      )
     ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
      (intern (format "=>>%s%s"
		      (make-string (string-to-int
				    (match-string 1 uri-feature))
				   ?>)
		      (substring uri-feature (match-end 0))))
      )
     ((string-match "^a\\." uri-feature)
      (intern (format "=>%s" (substring uri-feature (match-end 0))))
      )
     ((string-match "^a\\([0-9]+\\)\\." uri-feature)
      (intern (format "%s>%s"
		      (make-string (string-to-int
				    (match-string 1 uri-feature))
				   ?=)
		      (substring uri-feature (match-end 0))))
      )
     ((and (setq feature (intern (format "=>%s" uri-feature)))
	   (find-charset feature))
      feature)
     ((and (setq feature (intern (format "=>>%s" uri-feature)))
	   (find-charset feature))
      feature)
     ((and (setq feature (intern (format "=>>>%s" uri-feature)))
	   (find-charset feature))
      feature)
     ((and (setq feature (intern (format "=%s" uri-feature)))
	   (find-charset feature))
      feature)
     (t (intern uri-feature)))))

(defun www-uri-encode-feature-name (feature-name)
  (setq feature-name (symbol-name feature-name))
  (cond
   ((string-match "^=\\([^=>]+\\)" feature-name)
    (concat "rep." (substring feature-name (match-beginning 1)))
    )
   ((string-match "^=>>\\([^=>]+\\)" feature-name)
    (concat "g." (substring feature-name (match-beginning 1)))
    )
   ((string-match "^=>>>\\([^=>]+\\)" feature-name)
    (concat "gi." (substring feature-name (match-beginning 1)))
    )
   ((string-match "^=>>\\(>+\\)" feature-name)
    (format "gi%d.%s"
	    (length (match-string 1 feature-name))
	    (substring feature-name (match-end 1)))
    )
   ((string-match "^=>\\([^=>]+\\)" feature-name)
    (concat "a." (substring feature-name (match-beginning 1)))
    )
   ((string-match "^\\(=+\\)>" feature-name)
    (format "a%d.%s"
	    (length (match-string 1 feature-name))
	    (substring feature-name (match-end 0)))
    )
   ((string-match "^->" feature-name)
    (concat "to." (substring feature-name (match-end 0)))
    )
   ((string-match "^<-" feature-name)
    (concat "from." (substring feature-name (match-end 0)))
    )
   (t feature-name)))

(defun www-uri-make-feature-name-url (uri-feature-name uri-char)
  (format "%s?feature=%s&char=%s"
	  chise-wiki-view-url uri-feature-name uri-char))

(defun www-uri-decode-object (genre char-rep)
  (let (ccs cpos)
    (cond
     ((string-match "\\(%3A\\|:\\)" char-rep)
      (setq ccs (substring char-rep 0 (match-beginning 0))
	    cpos (substring char-rep (match-end 0)))
      (setq ccs (www-uri-decode-feature-name ccs))
      (cond
       ((string-match "^0x" cpos)
	(setq cpos
	      (string-to-number (substring cpos (match-end 0)) 16))
	)
       (t
	(setq cpos (car (read-from-string cpos)))
	))
      (if (and (eq genre 'character)
	       (numberp cpos))
	  (decode-char ccs cpos)
	(concord-decode-object ccs cpos genre))
      )
     (t
      (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
      (cond
       ((eq genre 'character)
	(when (= (length char-rep) 1)
	  (aref char-rep 0))
	)
       ((eq genre 'feature)
	(concord-decode-object
	 '=id (www-uri-decode-feature-name char-rep) 'feature)
	)
       (t
	(concord-decode-object
	 '=id (car (read-from-string char-rep)) genre)
	))))))

(defun www-uri-encode-object (object)
  (if (characterp object)
      (if (encode-char object '=ucs)
	  (mapconcat
	   (lambda (byte)
	     (format "%%%02X" byte))
	   (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
	   "")
	(let ((ccs-list '(; =ucs
			  =cns11643-1 =cns11643-2 =cns11643-3
			  =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
			  =gb2312 =gb12345
			  =jis-x0208 =jis-x0208@1990
			  =jis-x0212
			  =cbeta =jef-china3
			  =jis-x0213-1@2000 =jis-x0213-1@2004
			  =jis-x0208@1983 =jis-x0208@1978
			  =zinbun-oracle =>zinbun-oracle
			  =daikanwa
			  =gt =gt-k
			  =>>jis-x0208 =>>jis-x0213-1
			  =>jis-x0208 =>jis-x0213-1
			  =>>gt
			  =ruimoku-v6
			  =big5
			  =big5-cdp))
	      ccs ret)
	  (while (and ccs-list
		      (setq ccs (pop ccs-list))
		      (not (setq ret (encode-char object ccs 'defined-only)))))
	  (cond (ret
		 (format "%s:0x%X"
			 (www-uri-encode-feature-name ccs)
			 ret))
		((and (setq ccs (car (split-char object)))
		      (setq ret (encode-char object ccs)))
		 (format "%s:0x%X"
			 (www-uri-encode-feature-name ccs)
			 ret))
		(t
		 (format "system-char-id:0x%X"
			 (encode-char object 'system-char-id))
		 ))))
    (format "rep.id:%s" (concord-object-id object))))

(defun est-format-object (object)
  (if (characterp object)
      (char-to-string object)
    (format "%s" (concord-object-id object))))


;;; @ Feature name presentation
;;;

(defun www-format-feature-name-default (feature-name)
  (mapconcat
   #'capitalize
   (split-string
    (symbol-name feature-name)
    "-")
   " "))

(defun www-format-feature-name-as-metadata (feature-name &optional lang)
  (let ((str (symbol-name feature-name))
	base meta)
    (cond
     ((string-match "\\*[^*]+$" str)
      (setq base (substring str 0 (match-beginning 0))
	    meta (substring str (match-beginning 0)))
      (concat (www-format-feature-name* (intern base) lang)
	      meta))
     (t
      (www-format-feature-name-default feature-name)
      ))))

(defun www-format-feature-name-as-rel-to (feature-name)
  (concat "\u2192" (substring (symbol-name feature-name) 2)))

(defun www-format-feature-name-as-rel-from (feature-name)
  (concat "\u2190" (substring (symbol-name feature-name) 2)))

(defun www-format-feature-name-as-CCS (feature-name)
  (let* ((rest
	  (split-string
	   (symbol-name feature-name)
	   "-"))
	 (dest (upcase (pop rest))))
    (when (string-match "^=+>*" dest)
      (setq dest (concat (substring dest 0 (match-end 0))
			 " "
			 (substring dest (match-end 0)))))
    (cond
     (rest
      (while (cdr rest)
	(setq dest (concat dest " " (upcase (pop rest)))))
      (if (string-match "^[0-9]+$" (car rest))
	  (concat dest "-" (car rest))
	(concat dest " " (upcase (car rest))))
      )
     (t dest))))

(defun www-format-feature-name* (feature-name &optional lang)
  (let (name fn parent ret)
    (cond
     ((or (and lang
	       (char-feature-property
		feature-name
		(intern (format "name@%s" lang))))
	  (char-feature-property
	   feature-name 'name)))
     ((and (setq name (symbol-name feature-name))
	   (string-match "\\*" name))
      (www-format-feature-name-as-metadata feature-name lang))
     (t
      (setq fn feature-name)
      (while (and (setq parent (char-feature-name-parent fn))
		  (null (setq ret
			      (or (and lang
				       (char-feature-property
					parent
					(intern (format "name@%s" lang))))
				  (char-feature-property
				   parent 'name)))))
	(setq fn parent))
      (cond
       (ret
	(concat ret (substring (symbol-name feature-name)
			       (length (symbol-name parent)))))
       ((find-charset feature-name)
	(www-format-feature-name-as-CCS feature-name))
       ((string-match "^\\(->\\)" name)
	(www-format-feature-name-as-rel-to feature-name))
       ((string-match "^\\(<-\\)" name)
	(www-format-feature-name-as-rel-from feature-name))
       (t
	(www-format-feature-name-default feature-name)
	))
      ))))

(defun www-format-feature-name (feature-name &optional lang)
  (www-format-encode-string
   (www-format-feature-name* feature-name lang)))


;;; @ 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 'name)
					'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-encode-string (string &optional without-tags)
  (with-temp-buffer
    (insert string)
    (let (plane code start end char variants ret rret)
      (goto-char (point-min))
      (while (search-forward "<" nil t)
	(replace-match "&lt;" nil t))
      (goto-char (point-min))
      (while (search-forward ">" nil t)
	(replace-match "&gt;" nil t))
      (if without-tags
	  (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
	(let ((coded-charset-entity-reference-alist
	       (list*
		'(=gt			"GT-" 5 d)
		'(=cns11643-1		"C1-" 4 X)
		'(=cns11643-2		"C2-" 4 X)
		'(=cns11643-3		"C3-" 4 X)
		'(=cns11643-4		"C4-" 4 X)
		'(=cns11643-5		"C5-" 4 X)
		'(=cns11643-6		"C6-" 4 X)
		'(=cns11643-7		"C7-" 4 X)
		'(=gb2312		"G0-" 4 X)
		'(=gb12345		"G1-" 4 X)
		'(=jis-x0208@1990	"J90-" 4 X)
		'(=jis-x0212		"JSP-" 4 X)
		'(=cbeta		"CB" 5 d)
		'(=jis-x0208@1997	"J97-" 4 X)
		'(=jis-x0208@1978	"J78-" 4 X)
		'(=jis-x0208@1983	"J83-" 4 X)
		'(=ruimoku-v6		"RUI6-" 4 X)
		'(=zinbun-oracle	"ZOB-" 4 d)
		'(=jef-china3		"JC3-" 4 X)
		'(=daikanwa		"M-" 5 d)
		coded-charset-entity-reference-alist)))
	  (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)

	  (goto-char (point-min))
	  (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
	    (setq code (string-to-int (match-string 1)))
	    (replace-match
	     (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\">"
		     code
		     chise-wiki-bitmap-glyphs-url
		     (/ code 1000) code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
	    (setq plane (match-string 1)
		  code (string-to-int (match-string 2) 16))
	    (replace-match
	     (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\">"
		     plane code
		     chise-wiki-bitmap-glyphs-url
		     plane
		     (- (lsh code -8) 32)
		     (- (logand code 255) 32))
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
	    (setq plane (string-to-int (match-string 1))
		  code (string-to-int (match-string 2) 16))
	    (replace-match
	     (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\">"
		     plane code
		     chise-wiki-bitmap-glyphs-url
		     plane
		     (- (lsh code -8) 32)
		     (- (logand code 255) 32))
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
	    (setq plane (string-to-int (match-string 1))
		  code (string-to-int (match-string 2) 16))
	    (replace-match
	     (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\">"
		     plane code
		     chise-wiki-bitmap-glyphs-url
		     plane code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
	    (setq code (string-to-int (match-string 1) 16))
	    (replace-match
	     (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
		     code code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
	    (setq code (string-to-int (match-string 2)))
	    (replace-match
	     (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\">"
		     code
		     chise-wiki-bitmap-glyphs-url
		     code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
	    (setq code (string-to-int (match-string 2)))
	    (replace-match
	     (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\">"
		     code
		     chise-wiki-glyph-cgi-url
		     code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
	    (setq code (string-to-int (match-string 2)))
	    (replace-match
	     (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\">"
		     code
		     chise-wiki-glyph-cgi-url
		     code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
	    (setq code (string-to-int (match-string 1) 16))
	    (replace-match
	     (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\">"
		     code
		     chise-wiki-glyph-cgi-url
		     code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
	    (setq code (string-to-int (match-string 1) 16))
	    (replace-match
	     (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\">"
		     code
		     chise-wiki-glyph-cgi-url
		     code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
	    (setq code (string-to-int (match-string 1) 16))
	    (replace-match
	     (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\">"
		     code
		     chise-wiki-glyph-cgi-url
		     code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
	    (setq code (string-to-int (match-string 2) 16))
	    (replace-match
	     (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\">"
		     code
		     code)
	     t 'literal))

	  (goto-char (point-min))
	  (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
	    (setq code (string-to-int (match-string 1) 16))
	    (setq start (match-beginning 0)
		  end (match-end 0))
	    (setq char (decode-char 'system-char-id code))
	    (cond
	     ((and (setq variants
			 (or (www-get-feature-value char '->subsumptive)
			     (www-get-feature-value char '->denotational)))
		   (progn
		     (while (and variants
				 (setq ret (www-format-encode-string
					    (char-to-string (car variants))))
				 (string-match "&MCS-\\([0-9A-F]+\\);" ret))
		       (setq variants (cdr variants)))
		     ret))
	      (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
		(goto-char start)
		(delete-region start end)
		(insert ret))
	      )
	     ((setq ret (or (www-get-feature-value char 'ideographic-combination)
			    (www-get-feature-value char 'ideographic-structure)))
	      (setq ret
		    (mapconcat
		     (lambda (ch)
		       (if (listp ch)
			   (if (characterp (setq rret (find-char ch)))
			       (setq ch rret)))
		       (if (characterp ch)
			   (www-format-encode-string
			    (char-to-string ch) without-tags)
			 (www-format-encode-string
			  (format "%S" ch) without-tags)))
		     ret ""))
	      (when ret
		(goto-char start)
		(delete-region start end)
		(insert ret))
	      )))
	  ))
      ;; (goto-char (point-min))
      ;; (while (search-forward "&GT-" nil t)
      ;;   (replace-match "&amp;GT-" t 'literal))
      (buffer-string))))

(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?char=%s&feature=%s&format=%s\"
><input type=\"submit\" value=\"edit\" /></a>"
	      ret
	      chise-wiki-edit-url
	      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)))


;;; @ XML generator
;;;

(defun www-xml-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" val) 'without-tags))))
    dest))

(defun www-xml-format-unit (format-unit)
  (let (name props children ret)
    (cond
     ((stringp format-unit)
      (mapconcat (lambda (c)
		   (cond
		    ((eq c ?&) "&amp;")
                    ;; ((eq c ?<) "&amp;lt;")
                    ;; ((eq c ?>) "&amp;gt;")
		    (t
		     (char-to-string c))))
		 (www-format-encode-string format-unit 'without-tags)
		 "")
      )
     ((consp format-unit)
      (setq name (car format-unit)
	    props (nth 1 format-unit)
	    children (nthcdr 2 format-unit))
      (when (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))))
      (if children
	  (format "<%s%s>%s</%s>"
		  name
		  (if props
		      (www-xml-format-props props)
		    "")
		  (www-xml-format-list children)
		  name)
	(format "<%s%s/>"
		name (www-xml-format-props props)))
      )
     (t
      (format "%s" format-unit)))))

(defun www-xml-format-list (format-list)
  (if (atom format-list)
      (www-xml-format-unit format-list)
    (mapconcat #'www-xml-format-unit
	       format-list "")))


;;; @ HTML generator
;;;

(defun www-html-display-text (text)
  (princ
   (with-temp-buffer
     (insert text)
     (goto-char (point-min))
     (while (search-forward "<" nil t)
       (replace-match "&lt;" nil t))
     (goto-char (point-min))
     (while (search-forward ">" nil t)
       (replace-match "&gt;" nil t))
     (goto-char (point-min))
     (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
       (replace-match
	(format "<a href=\"%s\">%s</a>"
		(match-string 2)
		(match-string 1))
	nil t))
     (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
     (goto-char (point-min))
     (while (search-forward "&GT-" nil t)
       (replace-match "&amp;GT-" nil t))
     (buffer-string))))

(defun www-html-display-paragraph (text)
  (princ "<p>")
  (www-html-display-text text)
  (princ "</p>\n"))


;;; @ for GlyphWiki
;;;

(defvar coded-charset-GlyphWiki-id-alist
  '((=ucs		"u"	4 x nil)
    (=ucs@JP		"u"	4 x nil)
    (=ucs@jis		"u"	4 x nil)
    (=ucs@gb		"u"	4 x "-g")
    (=ucs@cns		"u"	4 x "-t")
    (=ucs@ks		"u"	4 x "-k")
    (=ucs@iso		"u"	4 x "-u")
    (=ucs@unicode	"u"	4 x "-us")
    (=adobe-japan1-6	"aj1-"	5 d nil)
    (=gt		"gt-"	5 d nil)
    (=big5-cdp		"cdp-"	4 x nil)
    (=cbeta		"cb"	5 d nil)
    (=jis-x0208@1978/1pr "j78-"	4 x nil)
    (=jis-x0208@1978/-4pr "j78-" 4 x nil)
    (=jis-x0208@1978	"j78-"	4 x nil)
    (=jis-x0208@1983	"j83-"	4 x nil)
    (=jis-x0208@1990	"j90-"	4 x nil)
    (=jis-x0212		"jsp-"	4 x nil)
    (=jis-x0213-1@2000	"jx1-2000-" 4 x nil)
    (=jis-x0213-1@2004	"jx1-2004-" 4 x nil)
    (=jis-x0213-2	"jx2-"	4 x nil)
    (=cns11643-1	"c1-"	4 x nil)
    (=cns11643-2	"c2-"	4 x nil)
    (=cns11643-3	"c3-"	4 x nil)
    (=cns11643-4	"c4-"	4 x nil)
    (=cns11643-5	"c5-"	4 x nil)
    (=cns11643-6	"c6-"	4 x nil)
    (=cns11643-7	"c7-"	4 x nil)
    (=daikanwa		"dkw-"	5 d nil)
    (=gt-k		"gt-k"	5 d nil)
    (=jef-china3	"jc3-"	4 x nil)
    (=big5		"b-"	4 x nil)
    (=ks-x1001		"k0-"	4 x nil)
    ))

(defun char-GlyphWiki-id (char)
  (let ((rest coded-charset-GlyphWiki-id-alist)
	spec ret code)
    (while (and rest
		(setq spec (pop rest))
		(null (setq ret (char-feature char (car spec))))))
    (when ret
      (or
       (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
	    (cond
	     ((and (or (encode-char char '=jis-x0208@1990)
		       (encode-char char '=jis-x0212)
		       (encode-char char '=jis-x0213-1))
		   (setq code (encode-char char '=ucs@jis)))
	      (format "u%04x" code)
	      )
	     ((and (or (encode-char char '=gb2312)
		       (encode-char char '=gb12345))
		   (setq code (encode-char char '=ucs@gb)))
	      (format "u%04x-g" code)
	      )
	     ((and (or (encode-char char '=cns11643-1)
		       (encode-char char '=cns11643-2)
		       (encode-char char '=cns11643-3)
		       (encode-char char '=cns11643-4)
		       (encode-char char '=cns11643-5)
		       (encode-char char '=cns11643-6)
		       (encode-char char '=cns11643-7))
		   (setq code (encode-char char '=ucs@cns)))
	      (format "u%04x-t" code)
	      )
	     ((and (encode-char char '=ks-x1001)
		   (setq code (encode-char char '=ucs@ks)))
	      (format "u%04x-k" code)
	      )))
       (format (format "%s%%0%d%s%s"
		       (nth 1 spec)
		       (nth 2 spec)
		       (nth 3 spec)
		       (or (nth 4 spec) ""))
	       ret)))))


;;; @ End.
;;;

(provide 'cwiki-common)

;;; cwiki-common.el ends here