;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LaTeXファイルで、目次を自動的に作成する
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 2007年1月 村瀬昌満 作成
;; 
;; .emacs ファイルに、以下のように記述する。
;; (load-file "/path-to/latex_table_of_contents.el")
;; また、以下のことを .emacs ファイルに書き込むと、C-c C-t で、
;; my-latex-table-of-contents を呼び出すことができる。
;; (add-hook 'latex-mode-hook 
;;           '(lambda () 
;;              (define-key tex-mode-map "\C-c\C-t" 'my-latex-table-of-contents)))
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 外部から呼び出せる関数 (interactiveなもの)
;; my-latex-table-of-contents
;;   目次を作成する。この関数をショートカットに登録するとよい。
;;
;; my-latex-goto-tex-source-key
;;   ソースファイルの対応行に移動する。目次バッファ上で、Returnを押すと呼ばれる。
;;
;; my-latex-goto-tex-source-mouse
;;   ソースファイルの対応行に移動する。目次バッファ上で、マウスをダブルクリックすると呼ばれる。
;;
;; my-latex-quit
;;   目次バッファを閉じる。目次バッファ上でqを押すと呼ばれる。
;;
;; my-latex-toggle-display-buffer
;;   my-latex-table-of-contents呼び出し後に、目次バッファをウィンドウに表示するかを切り替える。
;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; セクション用

(defun my-latex-search-text ()
  "セクション検索用の正規表現を返す。"
  (let* ((func #'(lambda (text)
                   (if text
                       (cons (symbol-name (car text)) (funcall func (cdr text)))
                     nil))))
    (concat "^[^\n]*\\\\\\(" (regexp-opt (funcall func (my-latex-section-names)) nil) "\\)\n*{"
            (my-latex-make-recursive-bracket-pattern) "}")))

(defun my-latex-get-section-type (str)
  "セクションのタイプを返す。"
  (let* ((func #'(lambda (text)
                   (if text
                       (if (string-match (concat "^[^\n]*\\\\" (symbol-name (car text)) "\n*{") str)
                           (car text)
                         (funcall func (cdr text)))
                     nil))))
    (funcall func (my-latex-section-names))))

(defun my-latex-search-next-section ()
  "次のセクションを検索し、その場所を返す。
セクションがなければ、nilを返す。"
  (re-search-forward (my-latex-search-text) nil t))

(defun my-latex-init-table-of-contents ()
  "目次部分の初期化"
  (save-excursion
    (set-buffer (my-latex-get-table-of-contents-buffer))
    (insert "目次\n")))

(defun my-latex-write-section-data (title type index)
  "現在のバッファにセクションのデータを書き込む。"
  (let* ((func #'(lambda (index-list section-types)
                   (if section-types
                       (if (eq type (car section-types))
                           (insert (number-to-string (car index-list)))
                         (progn (insert " ")
                                (funcall func (cdr index-list) (cdr section-types))))
                     nil))))
    (funcall func index (my-latex-section-names))
    (insert " ")
    (insert (my-latex-delete-linefeed title))
    (insert "\n")))

(defun my-latex-get-section-title (str)
  "セクションのタイトルを切り出して返す。"
  (let ((start (+ (string-match "{" str) 1)))
    (substring str start -1)))

(defun my-latex-get-next-section-index (index type)
  "セクションのインデックスを一つ次のものへずらす。"
  (let* ((func #'(lambda (index type section-list)
                   (if (eq type (car section-list))
                       (cons (+ (car index) 1) (make-list (- (length section-list) 1) 0))
                     (cons (car index) (funcall func (cdr index) type (cdr section-list)))))))
    (funcall func index type (my-latex-section-names))))

(defun my-latex-make-table-of-contents ()
  "目次を作成する。"
  (let ((section-index (make-list (length (my-latex-section-names)) 0)))
    (save-excursion
      (goto-char 1) ;;バッファの最初へ。

      ;;目次バッファへ移動し、初期化
      (my-latex-init-table-of-contents)

      ;;セクション名を抜き出し、表示。
      (let ((start 0)
            (end (my-latex-search-next-section)))
        (while end
          (setq start (match-beginning 0))
          (save-excursion
            (let* ((section-data (buffer-substring-no-properties start end))
                   (section-title (my-latex-get-section-title section-data))
                   (section-type (my-latex-get-section-type section-data))
                   (source-line (count-lines 1 end)))
              (setq section-index (my-latex-get-next-section-index section-index section-type))
              (set-buffer (my-latex-get-table-of-contents-buffer))
              ;;TeXソースファイルの該当行を記憶。
              (let ((head (point)))
                (my-latex-write-section-data section-title section-type section-index)
                (put-text-property head (+ head 1) 'tex-source-line source-line))))
          (goto-char end)
          (setq end (my-latex-search-next-section)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;表用

(defun my-latex-init-table-list ()
  (save-excursion
    (set-buffer (my-latex-get-table-of-contents-buffer))
    (insert "表\n")))

(defun my-latex-write-table-data (title index)
  "表情報を書き出す。"
  (insert (number-to-string index))
  (insert " ")
  (insert (my-latex-delete-linefeed title))
  (insert "\n"))

(defun my-latex-next-table-caption ()
  "次の表のキャプションを返す。"
  (let* ((caption-pos (re-search-forward 
                       (concat "^\\([^\n]*\\\\caption\n*{\\("
                               (my-latex-make-recursive-bracket-pattern)
                               "\\)\\)}")
                       nil t))
         (caption-start (match-beginning 1))
         (start (match-beginning 2)))
    (if caption-pos
        (let ((table-pos 0)
              (figure-pos 0))
          (save-excursion
            (setq table-pos (re-search-backward "^[^\n]*\\\\begin\n*{table\\*?}" nil t)))
          (if (eq table-pos nil) (setq table-pos -1))
          (save-excursion
            (setq figure-pos (re-search-backward "^[^\n]*\\\\begin\n*{figure\\*?}" nil t)))
          (if (eq figure-pos nil) (setq figure-pos -1))
          (if (> table-pos figure-pos)
              ;;みつけたとき
              (cons (buffer-substring-no-properties start (- caption-pos 1)) caption-start)
            (my-latex-next-table-caption)))
      nil)))

(defun my-latex-make-table-list ()
  "表の目次を作成する。"
  (let ((table-index 0))
    (save-excursion
      (goto-char 1) ;;バッファの最初へ。
      
      ;;目次バッファへ移動し初期化
      (my-latex-init-table-list)
      
      ;; テーブル名を抜き出し、表示
      (let* ((table-title-pos (my-latex-next-table-caption))
             (source-line 0))
        (while table-title-pos
          (setq source-line (count-lines 1 (+ (cdr table-title-pos) 1)))
          (save-excursion
            (set-buffer (my-latex-get-table-of-contents-buffer))
            (setq table-index (+ table-index 1))
            (let ((head (point)))
              (my-latex-write-table-data (car table-title-pos) table-index)
              (put-text-property head (+ head 1) 'tex-source-line source-line)))
          (setq table-title-pos (my-latex-next-table-caption)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;図用

(defun my-latex-init-figure-list ()
  (save-excursion
    (set-buffer (my-latex-get-table-of-contents-buffer))
    (insert "図\n")))

(defun my-latex-write-figure-data (title index)
  "図情報を書き出す。"
  (insert (number-to-string index))
  (insert " ")
  (insert (my-latex-delete-linefeed title))
  (insert "\n"))

(defun my-latex-next-figure-caption ()
  "次の表のキャプションを返す。"
  (let* ((caption-pos (re-search-forward 
                       (concat "^\\([^\n]*\\\\caption\n*{\\("
                               (my-latex-make-recursive-bracket-pattern)
                               "\\)\\)}")
                       nil t))
         (caption-start (match-beginning 1))
         (start (match-beginning 2)))
    (if caption-pos
        (let ((table-pos 0)
              (figure-pos 0))
          (save-excursion
            (setq table-pos (re-search-backward "^[^\n]*\\\\begin\n*{table\\*?}" nil t)))
          (if (eq table-pos nil) (setq table-pos -1))
          (save-excursion
            (setq figure-pos (re-search-backward "^[^\n]*\\\\begin\n*{figure\\*?}" nil t)))
          (if (eq figure-pos nil) (setq figure-pos -1))
          (if (> figure-pos table-pos)
              ;;みつけたとき
              (cons (buffer-substring-no-properties start (- caption-pos 1)) caption-start)
            (my-latex-next-figure-caption)))
      nil)))

(defun my-latex-make-figure-list ()
  "図の目次を作成する。"
  (let ((figure-index 0))
    (save-excursion
      (goto-char 1) ;;バッファの最初へ。
        
      ;;目次バッファへ移動し初期化
      (my-latex-init-figure-list)
        
      ;; 表名を抜き出し、表示
      (let ((figure-title-pos (my-latex-next-figure-caption))
            (source-line 0))
        (while figure-title-pos
          (setq source-line (count-lines 1 (+ (cdr figure-title-pos) 1)))
          (save-excursion
            (set-buffer (my-latex-get-table-of-contents-buffer))
            (setq figure-index (+ figure-index 1))
            (let ((head (point)))
              (my-latex-write-figure-data (car figure-title-pos) figure-index)
              (put-text-property head (+ head 1) 'tex-source-line source-line)))
          (setq figure-title-pos (my-latex-next-figure-caption)))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;共通

(defcustom my-latex-display-buffer t
  "目次バッファを表示するかを設定")

(defvar my-latex-source-buffer nil
  "LaTeXのソースバッファ")

(defun my-latex-get-table-of-contents-buffer ()
  "目次表示用のバッファを返す。"
  (get-buffer-create "*my-latex-table-of-contents*"))

(defun my-latex-get-workspace-buffer ()
  "ワークスペース用のバッファを返す。"
  (get-buffer-create "*my-latex-workspace*"))

(defun my-latex-make-recursive-pattern (pat1 pat2 num)
  "繰り返し用の正規表現を生成して返す。"
  (if (< num 1)
      (concat pat1 pat2)
    (concat pat1 (my-latex-make-recursive-pattern pat1 pat2 (- num 1)) pat2)))

(defun my-latex-make-recursive-bracket-pattern ()
  "波括弧が入れ子になったパターンを返す。"
  (let ((ignore-pattern "[^{}\\\\]*\\(\\\\.[^{}\\\\]*\\)*")) ;;\{のようなパターンなら無視する。
    (concat ignore-pattern 
            (my-latex-make-recursive-pattern
             (concat "\\({" ignore-pattern)
             (concat "}" ignore-pattern "\\)*")
             10))))  ;; 波括弧は10個までネストできる。

(defun my-latex-delete-linefeed (str)
  "改行を取り去る。"
  (while (string-match "\n" str)
    (setq str (replace-match " " nil nil str)))
  str)


(defun my-latex-section-names ()
  "Sectionになりうるコマンドを返す"
  '(chapter section subsection subsubsection paragraph))

(defun my-latex-toggle-display-buffer ()
  "目次バッファを表示するかを切り換える。"
  (interactive)
  (setq my-latex-display-buffer (not my-latex-display-buffer)))

(defun my-latex-set-local-keymap ()
  "キーマップを設定する。RETでバッファの該当行への移動など。"
  (let ((map (make-sparse-keymap)))
    (set-keymap-parent map text-mode-map)
    (define-key map "\C-m" 'my-latex-goto-tex-source-key)
    (define-key map "q" 'my-latex-quit)
    (define-key map [drag-mouse-1] 'mouse-set-point) ;;このあたりは、double-mouse-1を有効にするのに必要。
    (define-key map [down-mouse-1] 'mouse-set-point)
    (define-key map [mouse-1] 'mouse-set-point)
    (define-key map [double-mouse-1] 'my-latex-goto-tex-source-mouse)
    (use-local-map map)))

(defun my-latex-goto-tex-source-key ()
  "TeXのソースファイルの編集行へ移動。(キーボード)"
  (interactive)
  (my-latex-goto-tex-source (point)))

(defun my-latex-goto-tex-source-mouse (event)
  "TeXのソースファイルの編集行への移動。(マウス)"
  (interactive "e")
  (let ((pos (posn-point (event-end event))))
    (my-latex-goto-tex-source pos)))

(defun my-latex-goto-tex-source (pos)
  "TeXのソースファイルの編集行へ移動"
  (save-excursion
    (goto-char pos)
    (beginning-of-line)
    (let ((tex-line (get-text-property (point) 'tex-source-line)))
      (if (not (equal tex-line nil))
          (progn (pop-to-buffer my-latex-source-buffer)
                 (goto-line tex-line))))))

(defun my-latex-init ()
  "全体の初期化"
  (save-excursion
    (setq my-latex-source-buffer (current-buffer))
    (set-buffer (my-latex-get-table-of-contents-buffer))
    (setq truncate-lines t)
    (setq buffer-read-only nil)
    (my-latex-set-local-keymap)
    (erase-buffer)))

(defun my-latex-end ()
  "全体の終了処理"
  (save-excursion
    (kill-buffer (my-latex-get-workspace-buffer))
    (set-buffer (my-latex-get-table-of-contents-buffer))
    (setq buffer-read-only t) ;;目次のバッファを書き込み禁止に。
    (goto-char 1) ;;目次の先頭へ。
    (if my-latex-display-buffer ;;目次のバッファを表示
        (display-buffer (my-latex-get-table-of-contents-buffer)))))

(defun my-latex-quit ()
  "目次バッファを閉じる。"
  (interactive)
  (condition-case nil
      (delete-window)
    (error (switch-to-buffer (other-buffer))))
  (bury-buffer (my-latex-get-table-of-contents-buffer)))

(defun my-latex-copy-document ()
  "ドキュメントの必要な部分を作業用バッファにコピーする。"
  (let ((str (buffer-string))
        (comment '("^[^%\n\\\\]*\\(\\\\.[^%\n\\\\]*\\)*\\(%.*$\\)" . 2))) ;;コメントのパターン
    ;;全体をコピー
    (set-buffer (my-latex-get-workspace-buffer))
    (erase-buffer)
    (insert str)

    ;;コメントを取り除く
    (goto-char 1)
    (while (re-search-forward (car comment) nil t)
      (replace-match "" t t nil (cdr comment)))

    ;;\begin{document}までを取り除く
    (let ((pos (progn (goto-char 1)
                      (search-forward "\\begin{document}" nil t)
                      (forward-line -1)
                      (point)))
          (end (progn (end-of-line)
                      (point))))
      (while (> end 1)
        (delete-backward-char (- end pos))
        (forward-line -1)
        (setq pos (point))
        (setq end (progn (end-of-line)
                         (point)))))))

(defun my-latex-table-of-contents ()
  "目次や表への参照を作成する。"
  (interactive)
  (my-latex-init)
  (save-excursion
    (save-restriction ;; ナローイングに対応
      (widen)
      (my-latex-copy-document)
      (my-latex-make-table-of-contents)
      (save-excursion
        (set-buffer (my-latex-get-table-of-contents-buffer))
        (insert "\n"))
      (my-latex-make-table-list)
      (save-excursion
        (set-buffer (my-latex-get-table-of-contents-buffer))
        (insert "\n"))
      (my-latex-make-figure-list)))
  (my-latex-end))