;; -*- 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))
	    (object (plist-get (nth 1 exp) :object))
	    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
	     (est-object-genre object)
	     (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