;;
;; SmartDoc helper functions
;;
;; @since   Jul. 15, 2000
;; @version Sep. 19, 2003
;; @author  ASAMI, Tomoharu (asami@XMLSmartDoc.org)
;;

(defvar sdoc-encodings '(("UTF-8" . nil)
			 ("us-ascii" . nil)
			 ("ISO-8859-1" . iso-8859-1)
			 ("Shift_JIS" . sjis)
			 ("EUC-JP" . euc-jp)
			 ("ISO-2022-JP" . iso-2022-jp)))

(defvar sdoc-languages '(("en" . ("UTF-8"
				  "us-ascii"
				  "ISO-8859-1"))
			 ("ja" . ("UTF-8"
				  "Shift_JIS"
				  "EUC-JP"
				  "ISO-2022-JP"))))

(defvar sdoc-entity-alist
  '(("\\\\" . "&bsol;")        ; 005C
    ("$B!=(B" . "&horbar;")        ; 2015
    ("~" . "&tilde;")          ; 007E
;    ("" . "&wdash;")          ; 301C
;    ("" . "&dvline;")         ; 2016
    ("$B!1(B" . "&fmacron;")       ; FFE3
    ("$B!@(B" . "&fbsol;")         ; FF3C
    ("$B!A(B" . "&ftild;")         ; FF5E
    ("$B!B(B" . "&fparato;")       ; 2225
    ("$B!](B" . "&fminus;")        ; FF0D
    ("$B!q(B" . "&fcent;")         ; FFE0
    ("$B!r(B" . "&fpoun;")         ; FFE1
    ("$B!o(B" . "&fyen;")          ; FFE5
    ("$B"L(B" . "&fnot;")          ; FFE2
;    ("" . "&fbrvbar;")       ; FFE4 XXX invalid character in emacs
    )
  "Symbols to use entities instead of raw characters.")

(defun sdoc-compile (&optional arg)
  (interactive "P")
  (if arg
      (sdoc-preview-plain)
    (sdoc-compile-all)))

(defun sdoc-compile-all ()
  (interactive)
  (if (not (boundp 'compile-command))	; by kiyoka@netfort.gr.jp
      (progn				; [sdocusersj 246]
	(setq compile-command "make -k")
	(setq compilation-read-command t)
	))
  (let
      ((buf1 compile-command)
       (buf2 compilation-read-command))
    (compile (concat "sdoc" " " buffer-file-name))
    (setq compile-command buf1)
    (setq compilation-read-command buf2)))

(defun sdoc-preview-plain ()
  (interactive)
  (let (buffer proc name)
    (setq filename buffer-file-name)
    (save-excursion
      (setq buffer (get-buffer-create "*SmartDoc preview*"))
      (set-buffer buffer)
      (erase-buffer)
      (message "Now formating ...")
      (setq proc
	    (start-process-shell-command
	     "sdoc" buffer
	     (concat "sdoc -verbose:false -packager:stdout -format:plain "
		     filename)))
      (set-process-sentinel proc (function sdoc-sentinel)))))

(defun sdoc-sentinel (proc msg)
  (let (buffer)
    (setq buffer (process-buffer proc))
    (save-excursion
      (set-buffer buffer)
      (goto-char (point-min))
      (message "Now formating ... Done.")
      (set-buffer-modified-p nil)
      (setq truncate-lines t)
      (pop-to-buffer buffer))))

(defun sdoc-kill-content ()
  (interactive)
  (let (start char)
    (save-excursion
      (cond ((re-search-backward "[<>'\"]" nil t)
	     (setq start (match-end 0))
	     (setq char (char-before start))
	     (goto-char (+ (point) 1))
	     (cond ((char-equal char ?>) ; between tag
		    (cond ((re-search-forward "<")
			   (kill-region start (match-beginning 0)))))
		   ((char-equal char ?<) ; inside tag
		    (cond ((re-search-forward ">")
			   (kill-region start (match-beginning 0)))))
		   ((char-equal char ?\") ; between double quotation
		    (cond ((re-search-forward "\"")
			   (kill-region start (match-beginning 0)))))
		   ((char-equal char ?\') ; between single quotation
		    (cond ((re-search-forward "\'")
			   (kill-region start (match-beginning 0)))))))))))

(defun sdoc-use-entities ()
  (interactive)
  (mapcar (function
	   (lambda (cell)
	     (let (start symbol entity)
	       (setq symbol (car cell))
	       (setq entity (cdr cell))
	       (save-excursion
		 (goto-char (point-min))
		 (while (re-search-forward symbol nil t)
		   (setq start (match-beginning 0))
		   (kill-region start (match-end 0))
		   (goto-char start)
		   (insert entity))))))
	  sdoc-entity-alist))

(defun sdoc-insert-prototype ()
  (interactive)
  (let (encoding lang title)
    (setq lang (completing-read "language : "
				(sdoc-language-candidates)))
    (if (equal lang "")
	(setq lang nil))
    (setq encoding (completing-read "encoding : "
				    (sdoc-encoding-candidates lang)))
    (if (equal encoding "")
	(setq encoding nil))
    (sdoc-set-buffer-encoding encoding)
    (setq title (read-string "title : "))
    (if (equal title "")
	(setq title nil))
    (goto-char 0)
    (insert "<?xml version='1.0'")
    (cond (encoding
	   (insert " encoding='")
	   (insert encoding)
	   (insert "'")))
    (insert " ?>\n")
    (insert "\n")
    (insert "<doc")
    (cond (lang
	   (insert " xml:lang='")
	   (insert lang)
	   (insert "'")))
    (insert ">\n")
    (insert "<head>\n")
    (insert "<title>")
    (if title
	(insert title))
    (insert "</title>\n")
    (insert "</head>\n")
    (insert "<body>\n")
    (insert "\n")
    (insert "</body>\n")
    (insert "</doc>\n")
    (re-search-backward "<body>\n")
    (goto-char (match-end 0))))

(defun sdoc-language-candidates ()
  (mapcar (function
	   (lambda (list)
	     (list (car list))))	; by mit@nines.nec.co.jp
	  sdoc-languages))		; [sdocusersj 178]

(defun sdoc-encoding-candidates (language)
  (let (entry)
    (cond ((null language)
	   "UTF-8")
	  ((equal language "")
	   "UTF-8")
	  ((setq entry (assoc language sdoc-languages))
	   (mapcar (function list) (cdr entry)))
	  (t
	   "UTF-8"))))

(defun sdoc-set-buffer-encoding (encoding)
  (let (entry system)
    (cond ((setq entry (assoc encoding sdoc-encodings))
	   (cond ((setq system (cdr entry))
		  (cond ((functionp 'set-buffer-file-coding-system)
			 (set-buffer-file-coding-system system)))))))))

;;

(defun sdoc-make-table-records ()
  (interactive)
  (let (start finish data)
    (save-excursion
      (cond ((re-search-backward "[>]" nil t)
	     (setq start (+ (match-end 0) 1))
	     (cond ((re-search-forward "[<]" nil t)
		    (setq finish (- (match-end 0) 1))
		    (save-restriction
		      (narrow-to-region start finish)
		      (setq data (sdoc-extract-data-list "[^,]+")))
		    (kill-region start finish)
		    (sdoc-make-table-records-by-data data))))))))

(defun sdoc-extract-data-list (regex)
  (let (list flag start finish data)
    (goto-char (point-min))
    (setq flag t)
    (while flag
      (save-restriction
	(end-of-line)
	(setq finish (point))
	(beginning-of-line)
	(setq start (point))
	(narrow-to-region start finish)
	(setq data (sdoc-extract-data regex))
	(and data
	     (setq list (cons data list))))
      (if (not (eq (forward-line) 0))
	  (setq flag nil)))
    (nreverse list)))

(defun sdoc-extract-data (regex)
  (let (list)
    (while (re-search-forward regex nil t)
      (setq list (cons (buffer-substring
			(match-beginning 0)
			(match-end 0))
		       list)))
    (nreverse list)))

(defun sdoc-make-table-records-by-data (data)
  (mapcar (function (lambda (list)
		      (insert "<tr>\n")
		      (sdoc-make-table-record-by-data list)
		      (insert "</tr>\n")))
	  data))

(defun sdoc-make-table-record-by-data (data)
  (mapcar (function (lambda (cell)
		      (insert "  <td>")
		      (insert cell)
		      (insert "</td>\n")))
	  data))

;;

(defun sdoc-auto-id-title ()
  (interactive)
  (sdoc-auto-id)
  (sdoc-auto-title))

(defun sdoc-auto-id ()
  (interactive)
  (let (value)
    (setq value (sdoc-get-element-attribute "src"))
    (cond (value
	   (setq value (file-name-nondirectory value))
	   (cond ((string-match "\\([^.]+\\)[.]\\([^.]+\\)" value)
		  (setq value (concat
			       (substring value
					  (match-beginning 1)
					  (match-end 1))
			       (sdoc-make-capital-string
				(substring value
					   (match-beginning 2)
					   (match-end 2)))))))
	   (setq value (sdoc-unique-id (concat "prog:" value)))
	   (sdoc-set-element-attribute "id" value)))))

(defun sdoc-make-capital-string (string)
  (concat (capitalize (substring string 0 1))
	  (substring string 1)))

(defun sdoc-unique-id (value)
  (let (counter candidate)
    (save-excursion
      (goto-char 0)
      (cond ((re-search-forward (concat "id=\"" value "\"") nil t)
	     (setq value (sdoc-id-body value))
	     (setq counter 1)
	     (setq candidate nil)
	     (while (null candidate)
	       (goto-char 0)
	       (setq candidate (concat value counter))
	       (cond ((re-search-forward (concat "id=\"" candidate "\"") nil t)
		      (setq candidate nil)
		      (setq counter (+ counter 1)))))
	     candidate)
	    (t
	     value)))))

(defun sdoc-id-body (id)
  (let (list result flag c)
    (setq list (reverse (string-to-char-list id)))
    (setq flag t)
    (while list
      (setq c (car list))
      (cond ((not (and flag (<= 48 c) (>= 57 c)))
	     (setq flag nil)
	     (setq result (cons c result))))
      (setq list (cdr list)))
    (char-list-to-string result)))

(defun sdoc-auto-title ()
  (interactive)
  (let (value)
    (setq value (sdoc-get-element-attribute "src"))
    (cond (value
	   (setq value (file-name-nondirectory value))
	   (sdoc-set-element-attribute "title" value)))))

(defun sdoc-get-element-attribute (attr)
  (let (start finish)
    (save-excursion
      (cond ((re-search-backward "[<]" nil t)
	     (setq start (match-end 0))
	     (cond ((re-search-forward "[>]" nil t)
		      (setq finish (match-beginning 0))
		      (goto-char start)
		      (cond ((re-search-forward
			      (concat attr "=['\"]\\([^'\"]*\\)['\"]")
			      finish
			      t)
			     (buffer-substring
			      (match-beginning 1)
			      (match-end 1)))))))))))

(defun sdoc-set-element-attribute (attr value)
  (interactive)
  (let (start finish)
    (save-excursion
      (cond ((re-search-backward "[<]" nil t)
	     (setq start (match-end 0))
	     (cond ((re-search-forward "/?[>]" nil t)
		    (setq finish (match-beginning 0))
		    (goto-char start)
		      (cond ((re-search-forward
			      (concat attr "=['\"]\\([^'\"]*\\)['\"]")
			      finish
			      t)
			     (setq start (match-beginning 1))
			     (setq finish (match-end 1))
			     (kill-region start finish)
			     (goto-char start)
			     (insert value))
			    (t
			     (goto-char finish)
			     (insert
			      (concat " "attr "=\"" value "\"")))))))))))

(defun sdoc-adjust-ids ()
  (interactive)
  (let (start finish id)
    (save-excursion
      (goto-char 0)
      (while (re-search-forward "id=['\"]\\([^'\"]*\\)['\"]" nil t)
	(setq start (match-beginning 1))
	(setq finish (match-end 1))
	(setq id (buffer-substring start finish))
	(save-excursion
	  (goto-char 0)
	  (re-search-forward (concat "id=\"" id "\"") nil t)
	  (cond ((re-search-forward (concat "id=\"" id "\"") nil t)
		 (sdoc-adjust-ids-sub id))))))))

(defun sdoc-adjust-ids-sub (id)
  (let (start finish)
    (save-excursion
      (goto-char 0)
      (while (re-search-forward (concat "id=['\"]\\(" id "\\)['\"]") nil t)
	(setq start (match-beginning 1))
	(setq finish (match-end 1))
	(setq new-id (sdoc-unique-id id))
	(cond ((not (equal new-id id))
	       (goto-char start)
	       (kill-region start finish)
	       (insert new-id)))))))

(defun sdoc-insert-internal-link (&optional arg)
  (interactive "P")
  (if arg
      (sdoc-insert-internal-link-select)
    (sdoc-insert-internal-link-first)))

(defun sdoc-insert-internal-link-first ()
  (interactive)
  (let (id)
    (setq id (sdoc-find-id))
    (sdoc-insert-link (concat "#" id))))

(defun sdoc-insert-internal-link-select ()
  (interactive)
  (let (id ids select)
    (setq id (sdoc-find-id))
    (setq ids (sdoc-find-all-ids))
    (setq select (completing-read
		  (if id
		      (concat "id (" id ") : ")
		    "id : ")
		  ids))
    (sdoc-insert-link (concat "#" select))))

(defun sdoc-insert-link (id)
    (insert "<a href=\"")
    (if id
	(insert id))
    (insert "\">")
    (save-excursion
    (insert "</a>")))

(defun sdoc-find-id ()
  (save-excursion
    (cond ((re-search-forward "id=\"\\([^\"]+\\)\"" nil t)
	   (buffer-substring (match-beginning 1) (match-end 1))))))

(defun sdoc-find-all-ids ()
  (let (ids id title)
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward "id=\"\\([^\"]+\\)\"" nil t)
	(setq id (buffer-substring (match-beginning 1) (match-end 1)))
	(setq ids (cons (cons id id) ids))))
;	(save-excursion
;	  (goto-char (match-beginning 1))
;	  (setq title (sdoc-get-element-attribute "title")))
;	(if title
;	    (setq ids (cons (cons (concat id " - " title) id) ids))
;	  (setq ids (cons (cons id id) ids)))))
    ids))

(defun sdoc-insert-program (&optional arg)
  (interactive "P")
  (if arg
      (sdoc-insert-program-partial)
    (sdoc-insert-program-whole)))

(defun sdoc-insert-program-whole (&optional filename)
  (interactive)
  (let ()
    (or filename
	(setq filename (read-file-name "file : " "")))
    (insert (concat "<program src=\"" filename "\"/>\n"))
    (save-excursion
      (goto-char (- (point) 5))
      (sdoc-auto-id-title))))

(defun sdoc-insert-program-partial (&optional filename keyword)
  (interactive)
  (let ()
    (or filename
	(setq filename (read-file-name "file : " "")))
    (or keyword
	(setq keyword (read-string "keyword : ")))
    (insert (concat "<program src=\"" filename "\""
		    " normalizer=\"javasrc\" javasrcKeyword=\"" keyword "\""
		    " title=\""))
    (save-excursion
      (insert (concat keyword "\" id=\"prog:" keyword "\"/>\n")))))

(defun sdoc-insert-figure (&optional filename)
  (interactive)
  (let (name id)
    (or filename
	(setq filename (read-file-name "file : " "")))
    (setq name (sdoc-get-component-body filename))
    (insert (concat "<figure src=\"" (sdoc-remove-suffix filename) "\""
		    " title=\""))
    (save-excursion
      (setq id (sdoc-unique-id (concat "fig:" name)))
      (insert (concat name "\" id=\"" id "\"/>\n")))))

(defun sdoc-remove-suffix (filename)
  (let (pos)
    (setq pos (string-match "[.]" filename))
    (cond (pos
	   (substring filename 0 pos))
	  (t
	   filename))))

(defun sdoc-get-component-body (filename)
  (let (pos)
    (setq pos (string-match "[^/]+$" filename))
    (cond (pos
	   (sdoc-remove-suffix (substring filename pos)))
	  (t
	   (sdoc-remove-suffix filename)))))

(provide 'sdoc-helper)
