;;; -*- Mode: Lisp; Package: editor -*-

;;; lib.l --- My Library.
;;
;; Created: [2006/10/25]
;; Last updated: [2008/10/19]

;;; Commentary:
;;
;; 環境依存設定
;;   Perl::Tidy
;;

;;; Change Log:

;;; Code:

(provide "lib")
(in-package "editor")

(defvar *my-frame-list* '(
                          "*tterm*"
                          "2ch"
                          "CalMemo"
                          "cFTP"
                          "HE"
                          "infoman"
                          "KaMail"
                          "RSS"
                          "WWW"
                          )
    "指定フレームリスト。"
    )


(defun my-open-lisp-load-file ()
    "\
require、autoload、load-library の指定ファイルを開く。
"
    (interactive)
    (let (
          ;; 指定された開くファイル
          let-file
          ;; 開くファイルのパス
          let-fullpath
          )

        (if (save-excursion
                (scan-buffer "(" :reverse t)
                (if (or (looking-at "(require[ \t\n]+\"\\([^\"]+\\)\"")
                        (looking-at "(autoload[ \t\n]+[^\"]+\"\\([^\"]+\\)\"")
                        (looking-at "(load-library[ \t\n]+\"\\([^\"]+\\)\"")
                        (looking-at "(si:\\*load-library[ \t\n]+\"\\([^\"]+\\)\"")
                        )
                        (setf let-file (match-string 1))
                    nil
                    )
                )

                ;; 開くファイルが見つかったとき
                (progn
                    (dolist (list-load-path *load-path*)
                        ;; 二重引用符で指定されたものをファイル名としフルパスに変換し格納
                        (setf let-fullpath (merge-pathnames let-file list-load-path))

                        (if (and (file-exist-p let-fullpath)
                                 (not (file-directory-p let-fullpath))
                                 )
                                ;; ファイルが存在すれば開いて終了
                                (progn
                                    (find-file let-fullpath)
                                    (return t)
                                    )

                            ;; 見つからなかったとき
                            (progn
                                ;; 拡張子を ".l" とする
                                (setf let-fullpath (concat let-fullpath ".l"))

                                (if (and (file-exist-p let-fullpath)
                                         (not (file-directory-p let-fullpath))
                                         )
                                        ;; ファイルが存在すれば開いて終了
                                        (progn
                                            (find-file let-fullpath)
                                            (return t)
                                            )

                                    ;; 見つからなかったとき
                                    (progn
                                        ;; 拡張子を ".lc" とする
                                        (setf let-fullpath (concat let-fullpath "c"))
                                        (if (and (file-exist-p let-fullpath)
                                                 (not (file-directory-p let-fullpath))
                                                 )
                                                ;; ファイルが存在すれば開いて終了
                                                (progn
                                                    (find-file let-fullpath)
                                                    (return t)
                                                    )

                                            ;; 見つからなかったとき
                                            (message "ファイルが見つかりません: ~A" let-file)
                                            )
                                        )
                                    )
                                )
                            )
                        )
                    )

            ;; 開くファイルが見つからなかったとき
            nil
            )
        )
    )


(defun my-cl-run ()
    "\
C、C++ Compile & 結果表示。
"
    (interactive)
    (let* (
           (let-file (get-buffer-file-name))
           (let-dir (directory-namestring let-file))
           (let-win (get-buffer-window (selected-buffer)))
           )
        (with-output-to-temp-buffer ("*output*" -5 nil)
            (set-local-window-flags (selected-buffer)
                                    (+ *window-flag-ruler*
                                       *window-flag-half-width-space*
                                       )
                                    nil
                                    )
            (execute-shell-command (concat "cl /GX " let-file)
                                   nil
                                   (selected-buffer)
                                   :exec-directory let-dir
                                   )
            )
        (unless (first-error)
            (delete-window)
            (with-output-to-temp-buffer ("*output*" t nil)
                (execute-shell-command (merge-pathnames (concat (pathname-name let-file) ".exe")
                                                        let-dir
                                                        )
                                       nil
                                       (selected-buffer)
                                       :exec-directory let-dir
                                       )
                )
            (set-window let-win)
            )
        )
    )


(export '(loto) "editor")

(defun loto ()
    (interactive)
    (let (
          (let-n 6)
          let-num
          let-list-num
          )
        (while (> let-n 0)
            (setf let-num (1+ (random 43)))
            (unless (find let-num let-list-num)
                (push let-num let-list-num)
                (decf let-n)
                )
            )
        (setf let-list-num (stable-sort let-list-num #'<))
        (insert (format nil
                        "~A,~D,~D,~D,~D,~D,~D"
                        (format-date-string "%Y/%m/%d")
                        (nth 0 let-list-num)
                        (nth 1 let-list-num)
                        (nth 2 let-list-num)
                        (nth 3 let-list-num)
                        (nth 4 let-list-num)
                        (nth 5 let-list-num)
                        )
                )
        )
    )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; バッファ

(defun my-kill-other-buffers ()
    "\
カレントバッファ以外を削除。
"
    (interactive)
    (let (
          ;; カレントバッファ名
          (let-buff-name (buffer-name (selected-buffer)))
          ;; 削除したバッファ数
          (let-num 0)
          )
        (dolist (
                 list-buf
                 (mapcar #'buffer-name
                         (buffer-list)
                         )
                 let-num
                 )
            ;; 隠しバッファ、"*scratch*" は削除しない
            (unless (or (string-equal list-buf
                                      " "
                                      :start1 0
                                      :end1 1
                                      )
                        (string-equal list-buf "*scratch*")
                        (string-equal list-buf let-buff-name)
                        )
                (kill-buffer list-buf)
                (incf let-num)
                )
            )
        )
    )


(defun my-emacs-save-buffer ()
    "\
バッファがファイルに関連付けされてないとき名前をつけて保存。
"
    (interactive)
    (if (file-visited-p)
            ;; 関連付けされているとき
            (save-buffer)

        ;; 関連付けされていないとき
        (call-interactively #'(lambda (filename)
                                  (interactive "FWrite file: "
                                      :title0 "Write File"
                                      :default0 *default-write-file-directory*
                                      )
                                  (and (rename filename)
                                       (save-buffer)
                                       (dolist (list-auto-mode-list (reverse *auto-mode-alist*))
                                           (when (string-matchp (car list-auto-mode-list) filename)
                                               ;; 拡張子がモード判定の連想リスト内にあるとき
                                               (if (get (cdr list-auto-mode-list) 'decode-auto-mode)
                                                       (funcall (cdr list-auto-mode-list) last-buffer)
                                                   (funcall (cdr list-auto-mode-list)
                                                            )
                                                   )
                                               )
                                           )
                                       )
                                  )
                            )
        )
    )


(defun my-save-some-buffers (&optional verbose)
    "\
開いているバッファ全てを保存。隠しバッファはセーブしない。

VERBOSE: non-nil のときそれぞれ保存するか尋ねる。
"
    (interactive "p")
    (long-operation
        (let (
              ;; 保存したバッファ数
              (let-count 0)
              )
            (save-excursion
                (dolist (list-buffer (buffer-list))
                    (when (and
                           ;; 保存が必要なバッファ
                           (need-buffer-save-p list-buffer)
                           ;; 隠しバッファ (先頭がスペース) を除く
                           (string/= (buffer-name list-buffer) " " :end1 1)
                           )

                        ;; バッファ保存

                        (set-buffer list-buffer)
                        (if (not (file-visited-p))
                                ;; ファイルに関連付けされていないバッファのとき
                                (progn
                                    (refresh-screen)
                                    (if (yes-no-or-cancel-p "~aを保存しますか？" list-buffer)
                                            ;; 保存するとき
                                            (progn
                                                (call-interactively 'write-file)
                                                (incf let-count)
                                                )
                                        ;; 保存しないときは変更フラグをクリア
                                        (not-modified)
                                        )
                                    )

                            ;; ファイルに関連付けされているバッファのとき
                            (when (or (not verbose)
                                      (progn
                                          (refresh-screen)
                                          (yes-no-or-cancel-p "~a~%を保存しますか？"
                                                              (get-buffer-file-name)
                                                              )
                                          )
                                      )
                                (save-buffer)
                                (incf let-count)
                                )
                            )
                        )
                    )
                )

            (message "~d個のファイルをセーブしました" let-count)
            t
            )
        )
    )


(defun my-delete-buffer-and-window (&optional current)
    "\
不要バッファ & ウィンドウ削除。

CURRENT: nil のときカレントウィンドウを、non-nil のとき他ウィンドウ全て
を削除。
"
    (interactive)

    ;; 不要バッファ削除
    (dolist (list-buffer (buffer-list))
        (when (member-if #'(lambda (buf-name)
                               (string= (buffer-name list-buffer) buf-name)
                               )
                         ;; 指定バッファ
                         '(
                           "*Buffer List*"
                           "*compilation*"
                           "*CSV: Convert*"
                           "*CSV: Record*"
                           "*CSV: View*"
                           "*dictionary*"
                           "*grep*"
                           "*Help*"
                           "*output*"
                           "*Run Script*"
                           "*Shell output*"
                           "*Syntax Check*"
                           )
                         )
            (delete-buffer (buffer-name list-buffer))
            )
        )

    ;; 不要ウィンドウ削除
    (when (and (not (member (pseudo-frame-name (selected-pseudo-frame))
                            ;; これらのフレームのときは削除しない
                            *my-frame-list*
                            :test #'equal
                            )
                    )
               (> (count-windows t) 2)
               )
        (if current
                (delete-other-windows)
            (delete-window)
            )
        )
    )


(defun my-kill-line-backward ()
    "\
カーソル位置から行頭までを削除。
"
    (interactive)
    (kill-region (point)
                 (progn
                     (goto-bol)
                     (point)
                     )
                 )
    )


(defun my-indent-region-whole-buffer ()
    "\
バッファ全体を indent-region。
"
    (interactive)
    (indent-region (point-min) (point-max))
    )


(defun my-goto-next-link ()
    "\
次のリンクへ移動。
"
    (interactive)
    (scan-buffer *clickable-uri-regexp*
                 :regexp t
                 :no-dup t
                 )
    )


(defun my-goto-previous-link ()
    "\
前のリンクへ移動。
"
    (interactive)
    (scan-buffer *clickable-uri-regexp*
                 :regexp t
                 :no-dup t
                 :reverse t
                 )
    )


;;====================================
;; ウィンドウフラグ設定

(defun my-local-window-flags-on ()
    "\
カレントバッファのウィンドウフラグを On。
"
    (interactive)
    (set-local-window-flags (selected-buffer)
                            (+
                             ;; タブ
                             *window-flag-tab*
                             ;; 改行
                             *window-flag-newline*
                             ;; 半角スペース
                             *window-flag-half-width-space*
                             ;; 全角スペース
                             *window-flag-full-width-space*
                             )
                            t
                            )
    )


(defun my-local-window-flags-off ()
    "\
カレントバッファのウィンドウフラグを Off。
"
    (interactive)
    (set-local-window-flags (selected-buffer)
                            (+
                             ;; タブ
                             *window-flag-tab*
                             ;; 改行
                             *window-flag-newline*
                             ;; 半角スペース
                             *window-flag-half-width-space*
                             ;; 全角スペース
                             *window-flag-full-width-space*
                             )
                            nil
                            )
    )

;; ウィンドウフラグ設定
;;====================================


;;====================================
;; スクロール

(defun my-previous-page-or-line ()
    "\
前ページ or 1 行上へ。
"
    (interactive)
    (unless (previous-page)
        (previous-virtual-line)
        )
    )


(defun my-next-page-or-line ()
    "\
次ページ or 1 行下へ。
"
    (interactive)
    (unless (next-page)
        (next-virtual-line)
        )
    )


(defun my-static-scroll-line-down ()
    "\
カーソル位置をそのままで 1 行下にスクロール。
"
    (interactive)
    (save-excursion
        (scroll-window 1)
        )
    )


(defun my-static-scroll-line-up ()
    "\
カーソル位置をそのままで 1 行上にスクロール。
"
    (interactive)
    (save-excursion
        (scroll-window -1)
        )
    )


(defun my-recenter-0 ()
    "\
カーソル行を画面の一番上へ。
"
    (interactive)
    (recenter 0)
    )

;; スクロール
;;====================================


;;====================================
;; カーソル行移動

(defun my-transpose-lines-down ()
    "\
カーソル行全体を下に移動。
"
    (interactive)
    (let (
          ;; カーソル行開始位置
          (let-beg (save-excursion
                       (goto-bol)
                       (point)
                       )
                   )
          ;; カーソル行終了位置
          (let-end (save-excursion
                       (goto-eol)
                       (point)
                       )
                   )
          ;; 現在の桁位置
          (let-col (current-column))
          )
        (insert (prog1
                        (buffer-substring let-beg let-end)
                    (delete-region let-beg let-end)
                    (delete-char)
                    (goto-eol)
                    (insert "\n")
                    )
                )
        (goto-column let-col)
        )
    )


(defun my-transpose-lines-up ()
    "\
カーソル行全体を上に移動。
"
    (interactive)
    (let (
          ;; カーソル行開始位置
          (let-beg (save-excursion
                       (goto-bol)
                       (point)
                       )
                   )
          ;; カーソル行終了位置
          (let-end (save-excursion
                       (goto-eol)
                       (point)
                       )
                   )
          ;; 現在の桁位置
          (let-col (current-column))
          )
        (insert (prog1
                        (buffer-substring let-beg let-end)
                    (delete-region let-beg let-end)
                    (delete-char -1)
                    (goto-bol)
                    (open-line)
                    )
                )
        (goto-column let-col)
        )
    )

;; カーソル行移動
;;====================================

;;====================================
;; カーソル移動

(defun my-current-point (&optional lfd)
    "カーソル位置のバイト位置を返す。"
    (let (
          (let-current-line (current-line-number))
          (let-current-byte (current-column))
          (let-byte 0)
          (let-n 0)
          let-return
          )
        (if *prefix-args*
                (setf lfd t)
            )
        (long-operation
            (save-excursion
                (goto-char (point-min))
                (while (< (current-line-number) let-current-line)
                    (setf let-byte (+ let-byte (current-line-columns)))
                    (forward-line)
                    (incf let-n)
                    )
                )
            )
        (if lfd
                (setf let-byte (- let-byte let-n))
            )
        (setf let-return (+ let-byte let-current-byte))
        let-return
        )
    )

(defun my-goto-point (pos)
    "指定バイト位置へ移動。"
    (interactive "nByte Point: ")
    (let (
          (let-line-num 0)
          (let-pos 0)
          (let-lfd (if *prefix-args*
                           t
                       )
                   )
          )
        (long-operation
            (goto-char (floor (/ pos 2)))
            (backward-char (current-line-number))
            (while (and (< 100 (setf let-pos (- pos (my-current-point let-lfd))))
                        (< let-line-num (current-line-number))
                        )
                (setf let-line-num (current-line-number))
                (forward-char (floor (/ let-pos 2)))
                (backward-char (- (current-line-number) let-line-num))
                )
            (setf let-pos (- pos
                             (progn
                                 (goto-bol)
                                 (my-current-point let-lfd)
                                 )
                             )
                  )
            (narrow-to-region (point) (point-max))
            (while (and (> let-pos (my-current-point let-lfd))
                        (/= (point) (point-max))
                        )
                (forward-char)
                )
            (widen)
            )
        (message "~D" (my-current-point let-lfd))
        )
    )

;; カーソル移動
;;====================================

;;; バッファ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ミニバッファ

;;;====================================
;;; IME を Off で開始

(defvar *my-start-minibuffer-toggle-ime* nil
    "ミニバッファに入る前の IME On/Off 状態。"
    )


(defun my-start-minibuffer-ime-off-1 (buf his)
    "IME を Off に。"
    (when (get-ime-mode)
        (toggle-ime)
        (setf *my-start-minibuffer-toggle-ime* t)
        )
    )


(defun my-start-minibuffer-ime-off-2 (buf his)
    "Minibuffer に入る前の IME の状態に戻す。"
    (when *my-start-minibuffer-toggle-ime*
        (toggle-ime)
        (setf *my-start-minibuffer-toggle-ime* nil)
        )
    )

;;; IME を Off で開始
;;;====================================

;;; ミニバッファ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 検索


(defvar *my-header-regstring* "^[ \t]*\\(★\\|■\\|◆\\)")

(defun my-search-header-forward (&optional rev)
    "指定ヘッダ前方検索"
    (interactive)
    (scan-buffer *my-header-regstring*
                 :no-dup t
                 :regexp t
                 :reverse rev
                 )
    (recenter 5)
    )

(defun my-search-header-backward ()
    "指定ヘッダ後方検索"
    (interactive)
    (my-search-header-forward t)
    )


(defun my-search-modified-line-forward ()
    "\
編集行を前方検索。
"
    (interactive)
    (goto-char (or (find-text-attribute
                    'modified-line
                    :start (1+ (save-excursion (goto-eol) (point)))
                    )
                   (plain-error "編集された行はありません")
                   )
               )
    )


(defun my-search-modified-line-backward ()
    "\
編集行を後方検索。
"
    (interactive)
    (goto-char (or (find-text-attribute
                    'modified-line
                    :end (1- (save-excursion (goto-bol) (point)))
                    :from-end t
                    )
                   (plain-error "編集された行はありません")
                   )
               )
    )


(defun my-isearch-yank-char ()
    "\
検索時、カーソル位置の文字を一文字ずつ追加。
"
    (interactive)
    (let* (
           (let-start (if (boundp '*migemo-on*)
                              (point)
                          (+ (point) (length *isearch-current-string*))
                          )
                      )
           (let-end (if (boundp '*migemo-on*)
                            (1+ (+ (point)
                                   (length *isearch-current-match-string*)
                                   )
                                )
                        (save-excursion
                            (goto-char let-start)
                            (1+ (point))
                            )
                        )
                    )
           (let-next-word (buffer-substring let-start let-end))
           )
        (when (boundp '*migemo-on*)
            (setf *isearch-current-string* let-next-word)
            )
        (when (and *isearch-smart-case*
                   (eq *case-fold-search* :smart)
                   (not (string-match "[A-Z]" *isearch-current-string*))
                   )
            (setf let-next-word (string-downcase next-word))
            )
        (isearch-push-status)
        (if (boundp '*migemo-on*)
                (progn
                    (migemo-toggle nil)
                    (isearch-scanner next-word nil))
            (isearch-scanner (concat *isearch-current-string* next-word) nil)
            )
        )
    )


(defun my-isearch-real-delete-char ()
    "\
検索時、カーソル位置の文字を一文字ずつ削除。
"
    (interactive)
    (unless (< (length *isearch-current-string*) 1)
        (setf *isearch-current-string*
              (if (boundp '*migemo-on*)
                      (progn
                          (migemo-toggle nil)
                          (buffer-substring (point)
                                            (+ (point)
                                               (length *isearch-current-match-string*)
                                               )
                                            )
                          )
                  (subseq *isearch-current-string*
                          0
                          (1- (length *isearch-current-string*))
                          )
                  )
              )
        )
    (setf *isearch-this-command* 'isearch-search-history-forward)
    )


;;====================================
;; 正規表現トグル

(defvar *my-isearch-use-regexp* nil
    "正規表現 使用フラグ。"
    )

(defun my-isearch-regexp-toggle ()
    "\
正規表現検索をトグル。
"
    (interactive)
    (when (boundp '*migemo-on*)
        (migemo-toggle nil)
        )
    (setf *my-isearch-use-regexp* (not *my-isearch-use-regexp*)
          *isearch-scanner-hook* #'(lambda (p)
                                       (setf *isearch-regexp* *my-isearch-use-regexp*)
                                       p
                                       )
          )
    (message "isearch ~[nomal~;regexp~]"
             (if *my-isearch-use-regexp* 1 0)
             )
    )

;; 正規表現トグル
;;====================================


;;====================================
;; コマンドラインから Grep

(export '(command-line-grep) "editor")

(defun command-line-grep ()
    "\
コマンドラインから Grep。
"
    (require "grepd")
    (let (
          (*grep-directory-name-hook* #'(lambda ()
                                            (pop si:*command-line-args*)
                                            )
                                      )
          )
        (declare (special *grep-directory-name-hook*))
        (grep-dialog)
        )
    )

;; コマンドラインから Grep
;;====================================

;;; 検索
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; セレクション

(defun my-quit ()
    "\
セレクション解除 & Quit。
"
    (interactive)
    (stop-selection)
    (quit)
    )


;; 文字単位で範囲選択
(defun my-start-selection-char ()
    "\
文字単位で範囲選択を開始。
"
    (interactive)
    (start-selection 2 nil)
    )


;; 短形範囲選択
(defun my-start-selection-rect ()
    "\
短形で範囲選択を開始。
"
    (interactive)
    (start-selection 3 nil)
    )


;; 短形編集メニュー表示
(defun my-app-rectangle-popup-menu ()
    "\
短形編集メニュー表示。
"
    (interactive)
    (track-popup-menu *app-rectangle-popup-menu*)
    )


;; リージョン - セレクション トグル
(defun my-exchange-region-and-selection ()
    "\
リージョン - セレクション トグル。
"
    (interactive)
    (let (
          let-start
          let-end
          )
        (case (get-selection-type)
            (
             (1 2)
             (setf
              let-start (selection-mark)
              let-end (selection-point)
              )
             (if (> let-start let-end)
                     (rotatef let-start let-end)
                 )
             (stop-selection)
             (set-mark let-start)
             (goto-char let-end)
             )
            (
             3
             (error "矩形選択はリージョンに変換できません")
             )
            (
             t
             (if (mark t)
                     (progn (setq let-start (mark))
                         (setq let-end (point))
                         (if (> let-start let-end)
                                 (rotatef let-start let-end)
                             )
                         (start-selection 2 t let-start)
                         (goto-char let-end)
                         )
                 (error "マークがないので選択範囲に変換できません")
                 )
             )
            )
        )
    )

;;; セレクション
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ウィンドウ

(defun my-delete-other-buffer-and-window ()
    "\
カレントウィンドウ以外削除 & 不要バッファ削除。
"
    (interactive)
    (my-delete-buffer-and-window t)
    )


(defun my-next-page-other-window (&optional arg)
    "\
次のウィンドウをページスクロール。

他ウィンドウがなくても警告を出さない。
"
    (interactive "p")
    (if (> (count-windows) 1)
            (if arg
                    (scroll-other-window t)
                (scroll-other-window)
                )
        nil
        )
    )


(defun my-previous-page-other-window ()
    "\
次のウィンドウを下にページスクロール。

他ウィンドウがなくても警告を出さない。
"
    (interactive)
    (my-next-page-other-window t)
    )


(defun my-next-page-previous-window (&optional arg)
    "\
前のウィンドウをページクロール。

他ウィンドウがなくても警告を出さない。
"
    (interactive "p")
    (other-window -1 t)
    (if arg
            (previous-page)
        (next-page)
        )
    (other-window 1 t)
    )


(defun my-previous-page-previous-window ()
    "\
前のウィンドウを下にページスクロール。

他ウィンドウがなくても警告を出さない。
"
    (interactive)
    (my-next-page-previous-window t)
    )


(defun my-scroll-up-other-window ()
    "\
他ウィンドウを 1 行上にスクロール。
"
    (interactive)
    (if (> (count-windows) 1)
            (scroll-up-other-window)
        nil
        )
    )


(defun my-scroll-down-other-window ()
    "\
他ウィンドウを 1 行下にスクロール。
"
    (interactive)
    (if (> (count-windows) 1)
            (scroll-down-other-window)
        nil
        )
    )


(defun my-scroll-window-horizontally (&optional (arg 1))
    "\
1 桁左にスクロール。
"
    (interactive)
    (scroll-window-horizontally arg)
    )

(defun my-scroll-window-horizontally-right ()
    "\
1 桁右にスクロール。
"
    (interactive)
    (scroll-window-horizontally -1)
    )

;;; ウィンドウ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ファイラ

(defun my-filer-forward-line (&optional arg)
    "\
次の行 or 先頭へ。
"
    (interactive)
    (let (
          (let-old-file (filer-get-current-file))
          )
        (if arg
                ;; 前の行 or 末尾へ
                (progn
                    (filer-forward-line arg)
                    (when (string= let-old-file (filer-get-current-file))
                        (filer-goto-eof)
                        )
                    )
            ;; 次の行 or 先頭へ
            (progn
                (filer-forward-line)
                (when (string= let-old-file (filer-get-current-file))
                    (filer-goto-bof)
                    )
                )
            )
        )
    )


(defun my-filer-backward-line (&optional (arg 1))
    "\
前の行 or 末尾へ.。
"
    (interactive)
    (my-filer-forward-line (- arg))
    )


;;====================================
;; Recenter

(eval-when (:compile-toplevel :load-toplevel :execute)
    (require "wip/winapi")
    )

(unless (fboundp 'GetForegroundWindow)
    (c:*define-dll-entry winapi::HWND GetForegroundWindow () "user32")
    )

(unless (fboundp 'FindWindowEx)
    (c:*define-dll-entry winapi::HWND FindWindowEx
        (winapi::DWORD winapi::DWORD winapi::LPCSTR winapi::LPCSTR)
        "user32" "FindWindowExA")
    )


(defun my-filer-recenter ()
    "\
Filer Recenter.
"
    (let* (
           (position (winapi::make-POINT))
           (rect (winapi::make-RECT))
           (listview (let* (
                            (lc (si:make-string-chunk "SysListViewEx32"))
                            (lh (FindWindowEx (GetForegroundWindow)
                                              0
                                              lc
                                              0
                                              )
                                )
                            )
                         (if (filer-left-window-p)
                                 lh
                             (FindWindowEx (GetForegroundWindow)
                                           lh
                                           lc
                                           0
                                           )
                             )
                         )
                     )
           index
           )
        (setq index (winapi::SendMessage listview #x100c -1 1))
        (when (and (< -1 index)
                   (eq (winapi::SendMessage listview #x1010 index position)
                       1
                       )
                   )
            (winapi::GetClientRect listview rect)
            (winapi::SendMessage listview
                                 #x1014
                                 0
                                 (- (winapi::POINT-y position)
                                    (truncate (/ (winapi::RECT-bottom rect) 2))
                                    )
                                 )
            )
        )
    )

;; Recenter
;;====================================

;;; ファイラ
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; my-help-modifier

(defun my-get-index ()
    "\
索引文字列を取得。
"
    (let (
          let-beg
          let-end
          )
        (if (pre-selection-p)
                (setf let-beg (selection-mark)
                      let-end (selection-point)
                      )
            (save-excursion
                (setf let-end (prog2 (skip-syntax-spec-forward "w_j") (point)))
                (setf let-beg (prog2 (skip-syntax-spec-backward "w_j") (point)))
                )
            )
        (unless (= let-beg let-end)
            (buffer-substring let-beg let-end)
            )
        )
    )


(defun my-view-info-reference ()
    "\
カーソル位置の単語でモード毎のマニュアルを検索。
"
    (interactive)
    (require "info2")
    (let (
          (let-buffer (selected-buffer))
          (let-index (my-get-index))
          )
        (when let-index
            (delete-other-windows)
            (split-window)
            (case buffer-mode
                ;; lisp-mode
                (
                 'lisp-mode
                 (info2-mode "~/info/Language/Lisp/reference/reference.info" "*Reference*")
                 (info2-index let-index)
                 )
                ;; lisp-interaction-mode
                (
                 'lisp-interaction-mode
                 (info2-mode "~/info/Language/Lisp/reference/reference.info" "*Reference*")
                 (info2-index let-index)
                 )
                ;; texinfo-mode
                (
                 'texinfo-mode
                 (info2-mode "~/info/Language/Texinfo/Texinfo.info" "*Reference*")
                 (info2-index let-index)
                 )

                ;; その他
                (
                 t
                 ;; CalMemo から検索
                 (require "grepd")
                 (setf
                  ;; 正規表現
                  *grep-regexp-search* t
                  ;; サブディレクトリも検索
                  *grep-subdir* t
                  )

                 ;; CalMemo ログディレクトリ Grep
                 (scan-files (decode-escape-sequence (concat "^\*.*" let-index) t)
                             "*.clm"
                             (merge-pathnames ".calmemo/log" (user-config-path))
                             )

                 ;; 複数見つからなければ即表示
                 (unless (> (buffer-lines) 2)
                     (first-error)
                     (my-recenter-0)
                     (other-window)
                     ;; Grep バッファを閉じる
                     (close-selected-buffer)
                     )
                 )
                )

            ;; 元いたバッファを表示しているウィンドウへ
            (set-window (get-buffer-window let-buffer))
            )
        )
    )


(defun my-manual ()
    "\
モード毎の Info の指定ノードを参照。
"
    (interactive)
    (require "info2")
    (let (
          (let-mode mode-name)
          (let-index (my-get-index))
          )
        (cond
         ;; lisp
         (
          (or (string-equal let-mode "Lisp")
              (string-equal let-mode "Lisp Interaction")
              )
          (when let-index
              (delete-other-windows)
              (split-window nil nil)
              (info2-mode "~/info/Language/Lisp/xyzzy_Lisp/xyzzy_Lisp.info" "*Manual*" let-index)
              (other-window)
              )
          )
         ;; texinfo-mode
         (
          (string-equal let-mode "Texinfo")
          (when let-index
              (delete-other-windows)
              (split-window nil)
              (info2-mode "~/info/Language/Texinfo/Texinfo.info" "*Manual*" let-index)
              (other-window)
              )
          )
         )
        )
    )


(defun my-describe-variable (symbol)
    "\
キーバインド表示。

カレントフレームが指定したフレームのときは \"Frame 1\" で表示。
"
    (interactive "vDescribe variable: ")

    ;; 指定フレームのときは Frame 1 に移動
    (if (member (pseudo-frame-name (selected-pseudo-frame))
                *my-frame-list*
                :test #'equal
                )
            (switch-pseudo-frame "Frame 1")
        )

    (with-output-to-temp-buffer ("*Help*")
        (format t "~s's value is " symbol)
        (if (boundp symbol)
                (prin1 (symbol-value symbol))
            (princ "void.")
            )
        (terpri)
        (cond (
               (constantp symbol)
               (format t "~s is constant.~%" symbol)
               )
              (
               (si:*specialp symbol)
               (format t "~s is special.~%" symbol)
               )
              )
        (terpri)
        (let (
              (doc (documentation symbol 'variable))
              )
            (princ (if doc doc "not documented."))
            (terpri)
            )
        )

    t
    )


(defun my-describe-key (key)

    "\
指定したキーにバインドされた関数と Docstring を表示。

カレントフレームが指定したフレームのときは \"Frame 1\" で表示。
"
    (interactive "kDescribe key: ")
    (let ((let-command (lookup-key-command key)))
        (if let-command
                (let (
                      (let-doc (and (symbolp let-command)
                                    (documentation let-command 'function)
                                    )
                               )
                      )
                    (if (member (pseudo-frame-name (selected-pseudo-frame))
                                *my-frame-list*
                                :test #'equal
                                )
                            (switch-pseudo-frame "Frame 1")
                        )

                    (with-output-to-temp-buffer ("*Help*")
                        (format t "~a runs the command ~A~%" (key-to-string key) let-command)
                        (when let-doc
                            (format t "~%Documentation:~%~%~A~%" let-doc)
                            )
                        )
                    (set-buffer (find-buffer "*Help*"))
                    )

            (message "~a is not bound" (key-to-string key))
            )
        )
    )


(defun my-count-string-buffer (str &optional reg)
    "\
バッファ中にある指定文字列にマッチする数をカウント。
"
    (interactive)
    (save-excursion
        (let ((let-num 0))
            (goto-char (point-min))
            (while (scan-buffer str :regexp reg :no-dup t)
                (incf let-num)
                )
            (message "バッファ中の~Aの数：~D" str let-num)
            )
        )
    )


(defun my-count-string-region (reg start end &optional reg)
    "\
リージョン中にある指定した正規表現にマッチする数をカウント。
"
    (interactive "r")
    (when (and (integerp start)
               (integerp end)
               )
        (save-excursion
            (let ((let-num 0))
                (goto-char start)
                (while (scan-buffer str :regexp reg :no-dup t :limit end)
                    (incf let-num)
                    )
                (message "リージョン中の~Aの数：~D" str let-num)
                )
            )
        )
    )


(defun my-count-words-buffer ()
    "\
バッファ中にある単語数をカウント。
"
    (interactive)
    (save-excursion
        (let (
              (let-num 0)
              )
            (goto-char (point-min))
            (while (< (point) (point-max))
                (forward-word)
                (incf let-num)
                )
            (message "バッファ中の単語数：~D" let-num)
            )
        )
    )


(defun my-count-words-region (start end)
    "\
リージョン中にある単語数をカウント。
"
    (interactive "r")
    (save-excursion
        (let ((let-num 0))
            (goto-char start)
            (while (< (point) end)
                (forward-word)
                (incf let-num)
                )
            (message "リージョン中の単語数：~D" let-num)
            )
        )
    )


(defun my-count-char-buffer ()
    "\
バッファ中の文字数をカウント。
"
    (interactive)
    (save-excursion
        (let (
              (let-num 0)
              )
            (goto-char (point-min))
            (while (< (point) (point-max))
                (forward-char)
                (incf let-num)
                )
            (message "バッファ中の文字数：~D" let-num)
            )
        )
    )


(defun my-count-char-region (start end)
    "\
リージョン中の文字数をカウント。
"
    (interactive "r")
    (save-excursion
        (let (
              (let-num 0)
              )
            (goto-char start)
            (while (< (point) end)
                (forward-char)
                (incf let-num)
                )
            (message "リージョンの文字数：~D" let-num)
            )
        )
    )


(defun my-describe-bindings ()

    "\
カレントバッファに割り当てられているキーバインドを一覧表示。

カレントフレームが指定したフレームのときは \"Frame 1\" で表示。
"
    (interactive)
    (let (
          (let-local (local-keymap))
          (let-global *global-keymap*)
          (let-minor (minor-mode-map))
          (let-shadow nil)
          )
        (long-operation
            (message "Building binding list...")

            (if (member (pseudo-frame-name (selected-pseudo-frame))
                        *my-frame-list*
                        :test #'equal
                        )
                    ;; 指定フレームのとき Frame 1 へ
                    (switch-pseudo-frame "Frame 1")
                )

            (with-output-to-temp-buffer ("*Help*" nil)
                (when let-minor
                    (format t "Minor Mode Bindings:~%key~20Tbinding~%---~20T-------")
                    (mapc #'(lambda (x)
                                (describe-bindings-1 "" x let-shadow)
                                (push x let-shadow)
                                )
                          let-minor
                          )
                    )
                (format t "Local Bindings:~%key~20Tbinding~%---~20T-------")
                (describe-bindings-1 "" let-local let-shadow)
                (push let-local let-shadow)
                (format t "~%Global Bindings:~%key~20Tbinding~%---~20T-------")
                (describe-bindings-1 "" let-global let-shadow)
                (goto-char 0)
                )
            )

        (set-buffer (find-buffer "*Help*"))
        (message "Building binding list...done")
        )
    )


(defun my-help-modifier ()
    "\
\(a\)propos     : 指定した正規表現に一致するシンボル一覧を表示。
\(b\)indings    : カレントバッファのキー割り当て一覧を表示。

\(c\)ommand     :
指定した正規表現に一致する Interactive 宣言されている関数一覧を表示。バ
インドされたキーも表示する。

\(C\)ount       :
バッファ or リージョン内の指定文字 or 単語 or 正規表現にマッチする文字を
カウント。

\(f\)unction    : 関数定義を表示。
\(g\)rep        : ~/lisp ディレクトリ内を Grep。
\(i\)nfo        : Info 起動。
\(k\)ey         : 指定したキーにバインドされた関数と Docstring を表示。
\(m\)anual      :
\(s\)essionLoad : 保存したセッションをロード。
\(S\)essionSave : 現在のセッションを保存。
\(v\)ariable    : 指定した変数の現在の値、種類、Docstring を表示。
"
    (interactive)
    (message "\(a\)propos \(b\)indings \(c\)ommand \(C\)ount \(f\)unction \(g\)rep \(i\)nfo \(k\)ey \(m\)anual \(s\)essionLoad \(S\)essionSave \(v\)ariable")
    (let (
          ;; 関数実行前の IME の状態
          (let-ime (get-ime-mode))
          ;; 実行するコマンド
          let-cmd
          )
        (toggle-ime nil)
        ;; コマンド格納
        (setf let-cmd
              (case (read-char)
                  ;; apropos
                  (
                   (#\a)
                   'apropos
                   )
                  ;; bindings
                  (
                   (#\b)
                   'my-describe-bindings
                   )
                  ;; command
                  (
                   (#\c)
                   'command-apropos
                   )
                  ;; Count
                  (
                   (#\C)
                   #'(lambda ()
                         (interactive)
                         (let* (
                                (let-list '("char" "words" "string" "regexp"))
                                (let-str (completing-read "Char or Words or String or Regexp: "
                                                          let-list
                                                          :default "char"
                                                          :case-fold t
                                                          )
                                         )
                                (let-buffer-or-region (completing-read "Buffer or Region: "
                                                                       '("buffer" "region")
                                                                       :default "buffer"
                                                                       :case-fold t
                                                                       :must-match t
                                                                       )
                                                      )
                                )
                             (case (position let-str let-list :test 'string-equal)
                                 ;; Char
                                 (
                                  0
                                  (if (string-equal let-buffer-or-region "buffer")
                                          (my-count-char-buffer)
                                      (my-count-char-region (mark t) (point))
                                      )
                                  )
                                 ;; Words
                                 (
                                  1
                                  (if (string-equal let-buffer-or-region "buffer")
                                          (my-count-words-buffer)
                                      (my-count-words-region (mark t) (point))
                                      )
                                  )
                                 ;; String
                                 (
                                  2
                                  (my-count-string-buffer (read-string "String: "))
                                  (my-count-string-region (read-string "String: ") (mark t) (point))
                                  )
                                 ;; Regexp
                                 (
                                  3
                                  (my-count-string-buffer (read-string "Regexp: ") t)
                                  (my-count-string-region (read-string "Regexp: ") (mark t) (point) t)
                                  )
                                 )
                             )
                         )
                   )
                  ;; function
                  (
                   (#\f)
                   'describe-function
                   )
                  ;; grep
                  (
                   (#\g)
                   #'(lambda ()
                         (interactive)
                         (let (
                               (let-index (my-get-index))
                               (let-directory (read-directory-name "Directory: "
                                                                   :default (merge-pathnames "lisp" (si:system-root))
                                                                   )
                                              )
                               (let-file-name (read-string "File Name: "
                                                           :default "*.l"
                                                           )
                                              )
                               )
                             (when (and let-index
                                        let-directory
                                        let-file-name
                                        )
                                 (require "grepd")
                                 (scan-files let-index
                                             let-file-name
                                             let-directory
                                             )
                                 )
                             )
                         )
                   )
                  ;; info
                  (
                   (#\i)
                   #'(lambda ()
                         (interactive)
                         (require "info2")
                         (unless (string-match "Frame [0-9]+"
                                               (pseudo-frame-name (selected-pseudo-frame))
                                               )
                             (switch-pseudo-frame "Frame 1")
                             )
                         (info2)
                         )
                   )
                  ;; key
                  (
                   (#\k)
                   'my-describe-key
                   )
                  ;; manual (未作成)
                  (
                   (#\m)
                   'my-manual
                   )
                  ;; sessionLoad
                  (
                   (#\s)
                   #'(lambda ()
                         (interactive)
                         (load-session (merge-pathnames "session"
                                                        (user-config-path)
                                                        )
                                       )
                         )
                   )
                  ;; SessionSave
                  (
                   (#\S)
                   #'(lambda ()
                         (interactive)
                         (save-session (merge-pathnames "session"
                                                        (user-config-path)
                                                        )
                                       t
                                       )
                         )
                   )
                  ;; variable
                  (
                   (#\v)
                   'my-describe-variable)
                  )
              )
        (clear-message)
        (toggle-ime let-ime)
        (when let-cmd
            (call-interactively let-cmd)
            )
        )
    )

;;; my-help-modifier
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; etc

;;====================================
;; Apache

(defvar *my-apache-path* nil
    "Apache httpd.exe へのパス。"
    )


(defun my-apache (arg)
    "\
Apache.

ARG :
\"start\"   : Start.
\"stop\"    : Stop.
\"restart\" : Restart.
"
    (interactive)
    (if *my-apache-path*
            (call-process (format nil
                                  "~A -w -n ~A -k ~A"
                                  *my-apache-path*
                                  "Apache2.2"
                                  arg
                                  )
                          )
        nil
        )
    )


(defun my-apache-start ()
    "\
Apache Start.
"
    (interactive)
    (my-apache "start")
    )


(defun my-apache-restart ()
    "\
Apache Retart.
"
    (interactive)
    (my-apache "restart")
    )


(defun my-apache-stop ()
    "\
Apache Stop.
"
    (interactive)
    (my-apache "stop")
    )

;; Apache
;;====================================


;;====================================
;; Another HTML-lint

(defvar *my-htmllint-file* nil
    "Another HTML-lint のファイル \"htmllint\" へのパス。"
    )

(defvar *my-htmllint-option* nil
    "Another HTML-lint 実行時のオプション。"
    )

(defun my-htmllint-exec ()
    "\
カレントバッファを Another HTML-lint でチェック。
"
    (interactive)
    (let (
          (let-file (get-buffer-file-name))
          )
        (when (and let-file
                   *my-htmllint-file*
                   )
            (pipe-command (format nil
                                  "perl \"~A\" ~A \"~A\""
                                  (map-slash-to-backslash *my-htmllint-file*)
                                  *my-htmllint-option*
                                  (map-slash-to-backslash let-file)
                                  )
                          )
            )
        )
    )

;; Another HTML-lint
;;====================================


;;====================================
;; command-launcher.l


(export '(cmd) "editor")

(defun cmd ()
    "\
command-launcher 起動。
"
    (interactive)
    (require "command-launcher")
    (let (
          (arg-list (if *prefix-args*
                            ;; リージョンを引数とする
                            (map-backslash-to-slash (buffer-substring (mark) (point)))

                        ;; カーソル位置周辺の文字列を引数とする
                        (save-excursion
                            (unless (pre-selection-p)
                                (skip-chars-forward "[a-zA-Z0-9]\\-_/~.@?&=;+(),'$!*:#%|]+")
                                (begin-selection)
                                (skip-chars-backward "[a-zA-Z0-9]\\-_/~.@?&=;+(),'$!*:#%|]+")
                                )
                            (selection-start-end (start end)
                                (map-backslash-to-slash (buffer-substring start end))
                                )
                            )
                        )
                    )
          )
        (cond
         ;; パス
         (
          (file-exist-p arg-list)
          (command-launcher arg-list)
          )
         ;; URI
         (
          (string-matchp *command-launcher-url-regexp* arg-list)
          (command-launcher arg-list)
          )
         ;; その他
         (t (command-launcher))
         )
        )
    )

;; command-launcher.l
;;====================================


;;====================================
;; Perl::Tidy

(defvar *perltidy-path* "C:/myroot/bin/ActivePerl/site/lib/perltidy.pl"
    "perltidy.pl へのパス"
    )

(defun my-perltidy-run ()
    "\
perltidy で整形。
"
    (interactive)
    (if (buffer-modified-p)
            (message "保存して！")
        (progn
            (call-process (concat "perl "
                                  *perltidy-path*
                                  " -b "
                                  (file-namestring (get-buffer-file-name))
                                  )
                          :exec-directory (directory-namestring (get-buffer-file-name))
                          :wait t
                          )
            (revert-buffer)
            )
        )
    )

;; Perl::Tidy
;;====================================


;;====================================
;; template-insert

(require "template-insert")
(export '(template) "editor")

(defun template (&optional extention)
    "\
Template 挿入。

EXTENTION: 挿入する Template の拡張子。
"
    (interactive)
    (let (
          ;; 挿入する Template の拡張子
          (let-extention (if extention
                                 extention
                             (read-string "Extention: ")
                             )
                         )
          ;; 関数実行前ポジション
          (let-from (point))
          )

        ;; Template 挿入
        (ti::insert-template-type (list (concat "*."
                                                let-extention
                                                )
                                        )
                                  )

        ;; キーワード置換
        (ti::expand-variables)
        )
    )

;; template-insert
;;====================================


;;====================================
;; 超絶列カーソル

(defvar *fsadf-highlight-args* '(:background 9)
    "超絶列カーソル色"
    )
(defvar *fsadf-toggle* nil
    "トグル変数"
    )

(defun fsadf-highlight ()
    "超絶列カーソル色付け"
    (delete-text-attributes :fsadf)
    (save-excursion
        (let ((let-column (current-virtual-column)))
            (goto-virtual-line (get-window-start-line))
            (dotimes (i (1+ (window-lines)))
                (when (or (= let-column (goto-virtual-column let-column))
                          (= (1+ let-column) (goto-virtual-column (1+ let-column)))
                          )
                    (unless (eq (following-char) #\TAB)
                        (apply #'set-text-attribute
                               (point)
                               (1+ (point))
                               :fsadf
                               *fsadf-highlight-args*
                               )
                        )
                    )
                (unless (next-virtual-line) (return))
                )
            )
        )
    )

(defun fsadf-highlight-toggle ()
    "超絶列カーソル色付けトグル"
    (interactive)
    (if *fsadf-toggle*
            (progn
                (setf *fsadf-toggle* nil)
                (delete-text-attributes :fsadf)
                (delete-hook '*post-command-hook* 'fsadf-highlight)
                )
        (progn
            (unless (find-text-attribute :fsadf)
                (add-hook '*post-command-hook* 'fsadf-highlight)
                )
            (fsadf-highlight)
            (setf *fsadf-toggle* t)
            )
        )
    )

;; 超絶列カーソル
;;====================================

;;; lib.l ends here