;; LaTeXファイルで、目次を自動的に作成する
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 2007年1月 村瀬昌満 作成
;; 
;; .xyzzy ファイルに、以下のように記述する。
;; (load-file "/path-to/latex_table_of_contents_xyzzy.l")
;; 
;; 外部から呼び出せる関数 (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 ()
  "セクション検索用の正規表現を返す。"
  (labels ((func (text)
                 (if (cdr text)
                     (concat (symbol-name (car text)) "\\|" (func (cdr text)))
                   (symbol-name (car text)))))
          (concat "^[^\n]*\\\\\\(" (func (my-latex-section-names)) "\\)\n*{"
                  (my-latex-make-recursive-bracket-pattern) "}")))

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

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

(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)
  "現在のバッファにセクションのデータを書き込む。"
  (labels ((func (index-list section-types)
                 (if section-types
                     (if (eq type (car section-types))
                         (insert (number-to-string (car index-list)))
                       (progn (insert " ")
                              (func (cdr index-list) (cdr section-types))))
                   nil)))
          (func index (my-latex-section-names))
          (insert " ")
          (insert (my-latex-delete-comment 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)
  "セクションのインデックスを一つ次のものへずらす。"
  (labels ((func (index type section-list)
                 (if (eq type (car section-list))
                     (cons (+ (car index) 1) (make-list (- (length section-list) 1) :initial-element 0))
                   (cons (car index) (func (cdr index) type (cdr section-list))))))
          (func index type (my-latex-section-names))))

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

      ;;目次バッファへ移動し、初期化
      (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 start end))
                   (section-title (my-latex-get-section-title section-data))
                   (section-type (my-latex-get-section-type section-data))
                   (source-line (current-line-number)))
              (setq section-index (my-latex-get-next-section-index section-index section-type))
              (set-buffer (my-latex-get-table-of-contents-buffer))
              (setq my-latex-source-line-number (cons (cons (current-line-number) source-line) my-latex-source-line-number))
              (my-latex-write-section-data section-title section-type section-index)))
          (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-comment title))
  (insert "\n"))

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

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

      ;; テーブル名を抜き出し、表示
      (let* ((table-title-pos (my-latex-next-table-caption))
             (source-line 0))
        (while table-title-pos
          (setq source-line (current-line-number))
          (save-excursion
            (set-buffer (my-latex-get-table-of-contents-buffer))
            (setq my-latex-source-line-number (cons (cons (current-line-number) source-line) my-latex-source-line-number))
            (setq table-index (+ table-index 1))
            (my-latex-write-table-data (car table-title-pos) table-index))
          (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-comment title))
  (insert "\n"))

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

      ;;目次バッファへ移動し初期化
      (my-latex-init-figure-list)

      ;; 表名を抜き出し、表示
      (let ((figure-title-pos (my-latex-next-figure-caption))
            (source-line 0))
        (while figure-title-pos
          (setq source-line (current-line-number))
          (save-excursion
            (set-buffer (my-latex-get-table-of-contents-buffer))
            (setq my-latex-source-line-number (cons (cons (current-line-number) source-line) my-latex-source-line-number))
            (setq figure-index (+ figure-index 1))
            (my-latex-write-figure-data (car figure-title-pos) figure-index))
          (setq figure-title-pos (my-latex-next-figure-caption)))))))

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

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

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

(defvar my-latex-source-line-number '()
  "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 "\\)*")
             5)))) ;; 波括弧は5つまでネストできる。

(defun my-latex-delete-comment (str)
  "改行を取り去る。"
  (substitute-string str "\n" " "))

(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)))
    (setq map (copy-keymap *text-mode-map*))
    (define-key map #\C-m 'my-latex-goto-tex-source-key)
    (define-key map #\q 'my-latex-quit)
    (define-key map #\LBtnDown 'my-latex-goto-tex-source-mouse)
    (use-keymap map)))

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

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

(defun my-latex-goto-tex-source (pos)
  "TeXのソースファイルの編集行へ移動"
  (let ((tex-line 0))
    (save-excursion
      (goto-char pos)
      (let ((index (current-line-number)))
        (labels ((find-line-num (line-num-list)
                                (if line-num-list
                                    (if (equal (caar line-num-list) index)
                                        (cdar line-num-list)
                                      (find-line-num (cdr line-num-list)))
                                  nil)))
                (setq tex-line (find-line-num my-latex-source-line-number)))))
    (if (not (equal tex-line nil))
        (progn (switch-to-buffer-other-window my-latex-source-buffer)
               (goto-line tex-line)))))

(defun my-latex-init ()
  "全体の初期化"
  (save-excursion
    (setq my-latex-source-buffer (selected-buffer))
    (setq my-latex-source-line-number '())
    (set-buffer (my-latex-get-table-of-contents-buffer))
    (setq buffer-read-only nil)
    (my-latex-set-local-keymap)
    (erase-buffer (selected-buffer))))

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

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

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

    ;;コメントを取り除く
    (labels ((comment-check (pattern-num)
                            (goto-char 0)
                            (while (my-latex-re-search-forward (car pattern-num))
                              (delete-region (match-beginning (cdr pattern-num)) (match-end (cdr pattern-num))))))
            (comment-check comment3))

    ;;\begin{document}までを取り除く
    (let ((pos (progn (goto-char 0)
                      (my-latex-search-forward "\\begin{document}")
                      (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))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; for xyzzy

(defun my-latex-re-search-forward (pattern)
  (if (scan-buffer pattern :no-dup nil :reverse nil :tail t :regexp t :limit nil)
      (point)
    nil))

(defun my-latex-re-search-backward (pattern)
  (if (scan-buffer pattern :no-dup nil :reverse t :tail nil :regexp t :limit nil)
      (point)
    nil))

(defun my-latex-search-forward (pattern)
  (if (scan-buffer pattern :no-dup nil :reverse nil :tail t :regexp nil :limit nil)
      (point)
    nil))

(defun number-to-string (num)
  (if (numberp num)
      (format nil "~D" num)
    ""))