;; -*- coding: utf-8-mcs-er -*-
(require 'cwiki-common)

(defun ruimoku-format-volume (spec value year lang)
  (when (stringp spec)
    (setq spec (car (read-from-string spec))))
  (cond ((eq spec 'YY) (if (eq lang 'cjk)
				 (format "%d年" year)
			       (format "%d" year)))
	((eq spec 00) value)
	((eq spec 01) (concat value "期"))
	((eq spec 02) (concat value "巻"))
	((eq spec 03) (concat value "号"))
	((eq spec 04) (concat value "&GT-35694;"))
	((eq spec 05) (concat value "&GT-33870;"))
	((eq spec 06) (concat value "&GT-56392;"))
	((eq spec 07) (concat value "輯"))
	((eq spec 08) (concat value "&GT-53119;"))
	((eq spec 09) (concat value "&GT-53119;&AJ1-03580;"))
	((eq spec 10) (concat value "冊"))
	((eq spec 11) (concat value "&AJ1-03580;冊"))
	((eq spec 12) (concat value "&J90-3C21;"))
	((eq spec 13) (concat value "&GT-18140;号"))
	((eq spec 14) (concat value "特&GT-56392;号"))
	((eq spec 15) (concat value "本"))
	((eq spec 16) (concat value "&AJ1-03580;"))
	((eq spec 51) (concat "Vol." value))
	((eq spec 52) (concat "No." value))
	((eq spec 53) (concat "Part " value))
	((eq spec 54) (concat "Issue " value))
	((eq spec 55) (concat "Tome " value))
	((eq spec 56) (concat "Tomo " value))
	((eq spec 57) (concat "Tomus " value))
	((eq spec 58) (concat "Fasc." value))
	((eq spec 59) (concat "Livre " value))
	((eq spec 60) (concat "Année " value))
	((eq spec 61) (concat "Bd." value))
	((eq spec 62) (concat "Heft " value))
	((eq spec 63) (concat "Nr." value))
	((eq spec 64) (concat "Jahrg." value))
	((eq spec 65) (concat "Jaarg." value))
	((eq spec 66) (concat "Trimestre" value))
	(t "")
	))


;;; @ 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)
      (if (eq (car value) 'omitted)
	  value
	(list* 'list
	       '(:separator " ")
	       (mapcar
		(lambda (unit)
		  (format "%S" unit))
		value)))
    (est-eval-value-as-S-exp value)))

;; (defun est-journal-volume-object-get-volume-format (spec feature)
;;   (when (integerp spec)
;;     (setq spec (format "%02d" spec)))
;;   (cond ((string= spec "YY") `((decimal (:feature
;;                                          ->published/date*year)) "年"))
;;         ((string= spec "00") `((decimal (:feature ,feature))))
;;         ((string= spec "01") `((decimal (:feature ,feature)) "期"))
;;         ((string= spec "02") `((decimal (:feature ,feature)) "巻"))
;;         ((string= spec "03") `((decimal (:feature ,feature)) "号"))
;;         ((string= spec "04") `((decimal (:feature ,feature)) "&GT-35694;"))
;;         ((string= spec "05") `((decimal (:feature ,feature)) "&GT-33870;"))
;;         ((string= spec "06") `((decimal (:feature ,feature)) "&GT-56392;"))
;;         ((string= spec "07") `((decimal (:feature ,feature)) "輯"))
;;         ((string= spec "08") `((decimal (:feature ,feature)) "&GT-53119;"))
;;         ((string= spec "09") `((decimal (:feature ,feature)) "&GT-53119;&AJ1-03580;"))
;;         ((string= spec "10") `((decimal (:feature ,feature)) "冊"))
;;         ((string= spec "11") `((decimal (:feature ,feature)) "&AJ1-03580;冊"))
;;         ((string= spec "12") `((decimal (:feature ,feature)) "&J90-3C21;"))
;;         ((string= spec "13") `((decimal (:feature ,feature)) "&GT-18140;号"))
;;         ((string= spec "14") `((decimal (:feature ,feature)) "特&GT-56392;号"))
;;         ((string= spec "15") `((decimal (:feature ,feature)) "本"))
;;         ((string= spec "16") `((decimal (:feature ,feature)) "&AJ1-03580;"))
;;         ((string= spec "51") `("Vol." ((decimal (:feature ,feature)))))
;;         ((string= spec "52") `("No." ((decimal (:feature ,feature)))))
;;         ((string= spec "53") `("Part " ((decimal (:feature ,feature)))))
;;         ((string= spec "54") `("Issue " ((decimal (:feature ,feature)))))
;;         ((string= spec "55") `("Tome " ((decimal (:feature ,feature)))))
;;         ((string= spec "56") `("Tomo " ((decimal (:feature ,feature)))))
;;         ((string= spec "57") `("Tomus " ((decimal (:feature ,feature)))))
;;         ((string= spec "58") `("Fasc." ((decimal (:feature ,feature)))))
;;         ((string= spec "59") `("Livre " ((decimal (:feature ,feature)))))
;;         ((string= spec "60") `("Année " ((decimal (:feature ,feature)))))
;;         ((string= spec "61") `("Bd." ((decimal (:feature ,feature)))))
;;         ((string= spec "62") `("Heft " ((decimal (:feature ,feature)))))
;;         ((string= spec "63") `("Nr." ((decimal (:feature ,feature)))))
;;         ((string= spec "64") `("Jahrg." ((decimal (:feature ,feature)))))
;;         ((string= spec "65") `("Jaarg." ((decimal (:feature ,feature)))))
;;         ((string= spec "66") `("Trimestre" ((decimal (:feature ,feature)))))
;;         (t nil)
;;         ))

(defun est-eval-journal-volume (value)
  (let ((journal (car (concord-object-get value '<-volume)))
	volume-type number-type
	year)
    (setq volume-type (concord-object-get journal 'volume/type/code)
	  number-type (concord-object-get journal 'number/type/code))
    (setq year (or (concord-object-get value '->published/date*year)
		   (concord-object-get
		    (car (concord-object-get value 'published/date)) 'year)))
    ;; (append (list (concord-object-get journal 'name))
    ;;         (est-journal-volume-object-get-volume-format
    ;;          volume-type '<-volume*volume)
    ;;         (est-journal-volume-object-get-volume-format
    ;;          number-type '<-volume*number)
    ;;         )
    (concat (concord-object-get journal 'name)
	    " "
	    (ruimoku-format-volume
	     volume-type
	     (concord-object-get value '<-volume*volume)
	     year 'cjk)
	    (ruimoku-format-volume
	     number-type
	     (concord-object-get value '<-volume*number)
	     year 'cjk))
    ))

;; (defun est-eval-creator (value)
;;   (est-eval-list
;;    '((value (:feature ->name))
;;      (string (:feature role*name)))
;;    value nil))
  
(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 (concord-object-genre value))
		    genre-o
		    format)
		(cond
		 ((eq genre 'journal-volume@ruimoku)
		  ;; (est-eval-list
		  ;;  (est-journal-volume-get-object-format value)
		  ;;  value nil)
		  (est-eval-journal-volume value)
		  )
                 ;; ((eq genre 'creator@ruimoku)
                 ;;  (est-eval-creator value)
                 ;;  )
		 (t
		  (setq genre-o (concord-decode-object '=id genre 'genre))
		  (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)))

(defun est-eval-value-as-creators-names (value)
  (if (listp value)
      (let (role-name)
	(list* 'creator-name
	       '(:separator " ")
	       (mapcar (lambda (creator)
			 (setq role-name
			       (concord-object-get creator
						   'role*name))
			 (est-eval-list
			  (list
			   '(value (:feature ->name))
			   (list
			    'object (list :object creator)
			    (or role-name
				(format "(%s)"
					(concord-object-get creator
							    'role*type)))))
			  creator nil)
			 )
		       value)
	       ))
    (est-eval-value-default value)))

(defun est-eval-value-as-created-works (value)
  (if (listp value)
      (list* 'creator-name
	     '(:separator " ")
	     (mapcar (lambda (creator)
		       (est-eval-list
			'((value (:feature ->created)))
			creator nil))
		     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))
	 ((eq format 'space-separated-creator-name-list)
	  (est-eval-value-as-creators-names value))
	 ((eq format 'space-separated-created-work-list)
	  (est-eval-value-as-created-works 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)))
  (if (consp value)
      (let ((ret (condition-case nil
		     (nthcdr 127 value)
		   (error nil nil))))
	(when ret
	  (setcdr ret
		  (list (list 'omitted
			      (list :object object :feature 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) 'omitted)
      (list 'omitted
	    (list :object object :feature feature-name)
	    "...")
      )
     ((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