;;;  minor-mode: pager-mode; package: pager
;;;  テキストファイル閲覧用のマイナーモード "pager-mode"
;;;
;;; 【設定方法】
;;;  www-modeとの併用を前提につくっています。あらかじめインストールしてください。
;;;  してないと、”パッケージが存在しません: "www"”とエラーになり組み込めません。
;;;  このファイルをsitelispディレクトリに入れて、
;;;  設定ファイル".xyzzy"に
;;;  (require "pager-mode")
;;;  といった記述を加えてください。
;;;
;;; 【操作方法】
;;;  M-xからpager-mode[RET]
;;;  ・共通なキー操作
;;;  　　　　　　　　↑キー:画面を１行上にスクロール
;;;  　　　　　　　　↓キー:画面を１行下にスクロール
;;;  　スペースまたは→キー:画面を一画面ぶん進める
;;;  　　　　　　　　←キー:画面を一画面ぶん戻す
;;;  　　　　　　　　　　 c:カーソル操作の許可・禁止をトグルする
;;;  　　　　　　　　　　 p:pager-mode終了
;;;  ・www-modeでのみ有効なキー
;;;  　　　　　　　　BSキー:履歴を１つ前にさかのぼる
;;;  　　　　　　　　　　 \:カーソルを次のリンクへ
;;;  　　　　　　　　　　 ^:カーソルを前のリンクへ
;;;
;;;  www-modeで自動的に起動するには.xyzzyファイルに
;;;  (add-hook 'www::*www-view-mode* 'pager-mode)
;;;  といった記述を加えてください
;;;
;;;  pager-modeを起動中は、他のバッファのカーソルの設定も変えてしまいます。
;;;  あしからずご了承ください。なるべく単独で使用することをお勧めします。
;;;
;;;  現状では多重起動すると意図したように動作しないので、www-mode以外では
;;;  多重起動できないようになっています。新しくpager-modeを起動すると、先に起動
;;;  していたほうは自動で終了します。
;;;
;;;  ページング中はカーソルが固定されますが、ctrlキー+f,b,n,pなどの操作で動かす
;;;  ことが出来ます。カーソルを移動した場合、スクロールしてもポイントしているポ
;;;  ジションが画面内にある間は同じポジションをポイントし続けますが、一度画面外
;;;  に出てしまうと、カーソルは画面の左上、つまり１行目の１桁目に退避されます。
;;;
;;;  テキストの折り返しをウィンドウの幅で行う設定で使用することを前提につくって
;;;  います。折り返し無しで、一行がウィンドウの幅より長くなっていると、このモー
;;;  ドは不便かもしれません。

;;;  モジュールおよびパッケージの宣言
(provide "pager-module")
(defpackage pager (:use "lisp" "editor"))

(in-package "pager")

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

(export '(*pager-mode-hook* *pager-mode-map* pager-mode))

;;;  共通のキー割り当てを設定
(defvar-local pager-mode nil)
(defvar *pager-mode-map* nil)
(defvar *pager-mode-hook* nil)
(unless *pager-mode-map*
  (setq *pager-mode-map* (make-sparse-keymap))
  (define-key *pager-mode-map* #\SPC 'pager-next-page)
  (define-key *pager-mode-map* #\@ 'pager-previous-page)
  (define-key *pager-mode-map* #\[ 'pager-next-page)
  (define-key *pager-mode-map* #\] 'pager-scroll-up)
  (define-key *pager-mode-map* #\: 'pager-scroll-down)
  (define-key *pager-mode-map* #\c 'toggle-caret-activate)
  (define-key *pager-mode-map* #\p 'quite-pager-mode))

;;;  ]:[@キーでもスクロールアップ･ダウン，ページアップ･ダウン出来るように
;;;  設定しています。

;;; 変数の宣言
(defvar *status-list* (make-list 0))
(defvar *caret-activate-flag* nil)
(defvar *paging-buffer* nil)
(defvar *minibuf-name* nil)

;;;  pager-modeチェック＆起動
(defun pager-mode ()
  (interactive)
  (if (and (equal (cadr *paging-buffer*) 'www::www-view-mode)
           (equal  buffer-mode 'www::www-view-mode))
      (progn (when *caret-activate-flag* (toggle-caret-activate))
             (setup-pager))
      (progn (unless (equal *paging-buffer* nil)
                     (quite-pager-mode))
             (setq *paging-buffer* (list (selected-buffer) buffer-mode))
             (add-hook '*before-delete-buffer-hook* 'remove-pager)
             (add-hook '*enter-minibuffer-hook* 'load-status)
             (add-hook '*exit-minibuffer-hook* 'save-status)
             (push buffer-read-only *status-list*)
             (toggle-read-only t)
             (save-status nil nil)
             (setq *caret-activate-flag* t)
             (toggle-caret-activate)
             (setup-pager)
             (when (equal buffer-mode 'www::www-view-mode)
                   (define-key *pager-mode-map* #\C-h 'www::www-history-back)
                   (define-key *pager-mode-map* #\^ 'www::www-view-previous-link)
                   (define-key *pager-mode-map* #\\ 'www::www-view-next-link)
                   (dolist (check-buffer (buffer-list))
                           (when (and (equal (buffer-local-value check-buffer 'buffer-mode)
                                             'www::www-view-mode)
                                      (not (buffer-local-value check-buffer 'pager-mode)))
                                 (set-buffer check-buffer)
                                 (setup-pager)))
                   (switch-to-buffer (car *paging-buffer*))
                   (pager-hook-setting nil))))
  (message "~A" "Welcome to pager mode.")
  (run-hooks '*pager-mode-hook*))

(pushnew '(pager-mode . "Pager") *minor-mode-alist* :key #'car)

;;;  pager-modeの設定
(defun setup-pager ()
  (editor::toggle-mode 'pager-mode t t)
  (update-mode-line t)
  (set-minor-mode-map *pager-mode-map*))

;;;  pager-mode終了
(defun quite-pager-mode ()
  (interactive)
  (if (equal (cadr *paging-buffer*) 'www::www-view-mode)
      (progn (when (equal buffer-mode 'www::www-view-mode)
                   (pager-hook-setting t))
                   (dolist (check-buffer (buffer-list))
                           (when (and (equal (buffer-local-value check-buffer 'buffer-mode)
                                             'www::www-view-mode)
                                      (buffer-local-value check-buffer 'pager-mode))
                                      (remove-pager check-buffer))))
    (remove-pager (car *paging-buffer*))))

;;;  pager-mode解除，バッファ削除に対応
(defun remove-pager (target-buffer)
  (let ((carrent-buffer (selected-buffer)))
       (if (buffer-local-value target-buffer 'pager-mode)
           (progn (set-buffer target-buffer)
                  (when (equal target-buffer (car *paging-buffer*))
                        (load-status nil nil)
                        (setq buffer-read-only (pop *status-list*))
                        (delete-hook '*before-delete-buffer-hook* 'remove-pager)
                        (delete-hook '*enter-minibuffer-hook* 'load-status)
                        (delete-hook '*exit-minibuffer-hook* 'save-status))
                  (editor::toggle-mode 'pager-mode nil t)
                  (update-mode-line t)
                  (unset-minor-mode-map *pager-mode-map*)
                  (when (equal target-buffer (car *paging-buffer*))
                        (setq *paging-buffer* nil)
                        (message "~A" "Quite pager mode. See you again."))
                  (switch-to-buffer carrent-buffer))
    (prog1 (eval t)))))

;;;  カーソル設定の保存，変更
(defun save-status (ent-buffer ext-buffer)
  (when (or (equal (car *paging-buffer*) nil) (equal ent-buffer *minibuf-name*))
        (push *normal-caret-shape* *status-list*)
        (push *blink-caret* *status-list*))
  (setq *normal-caret-shape* 1)
  (setq *blink-caret* *caret-activate-flag*))

;;;  カーソル設定の復元
(defun load-status (ext-buffer ent-buffer)
  (setq *minibuf-name* ext-buffer)
  (setq *blink-caret* (pop *status-list*))
  (setq *normal-caret-shape* (pop *status-list*)))

;;;  画面を一画面ぶん進めるコマンド
(defun pager-next-page ()
  (interactive)
  (let ((next-start-line (+ (get-window-start-line)
                            (- (window-lines) *next-screen-context-lines*)))
        (eof-flag t))
       (while (and (< (get-window-start-line) next-start-line) (equal eof-flag t))
              (setq eof-flag (pager-scroll-up)))))

;;;  画面を一画面ぶん戻すコマンド
(defun pager-previous-page ()
  (interactive)
  (let ((next-start-line (- (get-window-start-line)
                            (- (window-lines) *next-screen-context-lines*)))
        (bof-flag t))
       (when (<= next-start-line 0) (setq next-start-line 1))
       (while (and (> (get-window-start-line) next-start-line) (equal bof-flag t))
              (pager-scroll-down))))

;;;  画面を１行上にスクロールするコマンド
(defun pager-scroll-up ()
  (interactive)
  (if (= (current-virtual-line-number) (get-window-start-line))
      (prog1 (next-virtual-line 1)
             (recenter 0)
             (when (/= (current-virtual-column) 0)
                   (goto-virtual-column 0)))
      (prog1 (recenter (1- (get-window-line))))))

;;; 画面を一行下にスクロールするコマンド
(defun pager-scroll-down ()
  (interactive)
  (if (> (get-window-start-line) 1)
      (prog2 (when (= (1+ (get-window-line)) (window-lines))
                   (goto-virtual-line (get-window-start-line))
                   (when (/= (current-virtual-column) 0)
                         (goto-virtual-column 0)))
             (if (and (zerop (get-window-line)) (zerop (current-virtual-column)))
                 (prog1 (previous-virtual-line 1))
                 (prog1 (recenter (1+ (get-window-line))))))
      (prog1 (eval nil))))

;;; カーソルキー操作の許可・禁止をトグルするコマンド
(defun toggle-caret-activate ()
  (interactive)
  (if (setq *blink-caret* (setq *caret-activate-flag* (not *caret-activate-flag*)))
      (progn (define-key *pager-mode-map* #\Up 'previous-virtual-line)
             (define-key *pager-mode-map* #\Down 'next-virtual-line)
             (define-key *pager-mode-map* #\Left 'backward-char)
             (define-key *pager-mode-map* #\Right 'forward-char)
             (message "~A" "Caret Status: Movable"))
      (progn (define-key *pager-mode-map* #\Up 'pager-scroll-down)
             (define-key *pager-mode-map* #\Down 'pager-scroll-up)
             (define-key *pager-mode-map* #\Left 'pager-previous-page)
             (define-key *pager-mode-map* #\Right 'pager-next-page)
             (message "~A" "Caret Status: Deactive"))))

;;;  www-modeのhookの設定確認メッセージ
(defun pager-hook-setting (current-status)
  (unless (or current-status (member 'pager-mode www::*www-view-mode-hook*))
          (when (yes-or-no-p "~A~%~A"
              "www-modeでのpager-mode自動起動をＯＮにしますか？（現在：ＯＦＦ）"
              "ＯＮに変更すると、Ｗｅｂページで自動的に起動します。")
              (add-hook 'www::*www-view-mode-hook* 'pager-mode)))
  (when (and current-status (member 'pager-mode www::*www-view-mode-hook*))
        (when (yes-or-no-p "~A~%~A"
              "www-modeでのpager-mode自動起動をＯＦＦにしますか？（現在：ＯＮ）"
              "ＯＦＦに変更すると、手動での起動が必要になります。")
              (delete-hook 'www::*www-view-mode-hook* 'pager-mode))))

(in-package "user")
(use-package "pager")

;;;  ファイル"pager-mode.l"終了