xyzzy用Lispプログラム

vw-xyzzy.l

xyzzyをWZ(VZ)風に使うため、個人的に必要な機能を実装してみた例です。
試される場合は自己責任でお願いします。適当に切り貼りしてお使いください(vwcmd-で始まる関数がコマンドとして使用できる関数です)。

◎削除文字列バッファ関連
 削除文字列を専用のバッファに入れる各種削除コマンド/削除文字列の復活
◎範囲選択関連
 セレクションリングをテキストスタック風に使用/非選択時の段落コピー・カット/クリップボードと連係/段落の二重化
◎検索語関連
 検索文字列とオプションの指定のみを行うダイアログ/検索文字列の取得/検索文字列の挿入/最近検索した文字列の挿入ダイアログ
◎マーク・ジャンプ関連
 直前位置を記憶&直前位置へ戻る/マーク1〜4に記憶&ジャンプ/マークダイアログ
◎プロファイル関連
 最近開いたファイルのプロファイルの保存&復元

;;; vw-xyzzy.l
;;; xyzzyをWZ(VZ)風に使う
;;;



;;;. 削除文字列バッファ関連

(defvar *delete-ring* nil)
(defparameter *delete-ring-max* 64)

;;; 削除文字列バッファに文字列を追加
(defun vwfunc-delete-new (cursor-move string)
    (setq *delete-ring*
        (ed::push-kill-ring (cons cursor-move string) *delete-ring* *delete-ring-max*)))

;;;.. 前方一文字削除
;;; カーソル位置の手前の一文字を削除して、削除文字列バッファに追加する。
(defun vwcmd-delete-prev ()
    (interactive)
    (unless (bobp)
        (vwfunc-delete-new t (string (preceding-char)))
        (delete-backward-char)))

;;;.. 一文字削除
;;; カーソル位置の一文字を削除して、削除文字列バッファに追加する。
(defun vwcmd-delete-char ()
    (interactive)
    (unless (eobp)
        (vwfunc-delete-new nil (string (following-char)))
        (delete-char)))

;;;.. 前方単語削除
;;; 文頭方向の一単語を削除して、削除文字列バッファに追加する。
(defun vwcmd-delete-word-prev ()
    (interactive)
    (unless (bobp)
        (let ((end (point)) (start (progn (backward-word) (point))))
            (vwfunc-delete-new t (buffer-substring start end))
            (delete-region start end))))

;;;.. 単語削除
;;; 文末方向の一単語を削除して、削除文字列バッファに追加する。
(defun vwcmd-delete-word ()
    (interactive)
    (unless (eobp)
        (let ((start (point)) (end (progn (forward-word) (point))))
            (vwfunc-delete-new nil (buffer-substring start end))
            (delete-region start end))))

;;;.. 段落先頭までを削除
;;; 段落先頭までを削除して、削除文字列バッファに追加する。
;;; すでに段落先頭にいるときは何もしない。
(defun vwcmd-delete-para-top ()
    (interactive)
    (unless (bolp)
        (let ((end (point)) (start (progn (goto-bol) (point))))
            (vwfunc-delete-new t (buffer-substring start end))
            (delete-region start end))))

;;;.. 段落末尾までを削除
;;; 段落の末尾までを削除して、削除文字列バッファに追加する。
;;; すでに段落末尾にいるときは何もしない。
(defun vwcmd-delete-para-end ()
    (interactive)
    (unless (eolp)
        (let ((start (point)) (end (progn (goto-eol) (point))))
            (vwfunc-delete-new nil (buffer-substring start end))
            (delete-region start end))))

;;;.. 削除文字列の復活
;;; 削除された文字列を削除文字列バッファからポップする。
;;; 実行後のカーソル位置はその文字列を削除したコマンドに応じて変わる。
;;; バックスペース系なら移動して文字列の後ろへ、デリート系なら移動しない。
(defun vwcmd-undelete ()
    (interactive)
    (if *delete-ring*
        (let ((buffer (car *delete-ring*)))
            (if (car buffer)
                (insert (cdr buffer))
                (save-excursion (insert (cdr buffer))))
            (pop *delete-ring*)
            t)))


;;;. 範囲選択関連

;;; セレクションリングの先頭データをクリップボードにコピー
(defun vwfunc-yank-selection-to-clipboard ()
    (copy-to-clipboard (cdr (car *selection-ring*)))
    (setq *clipboard-newer-than-kill-ring-p* nil))

;;;.. カット
;;; 選択範囲をカットして、セレクションリングに追加する。
;;; バッファが選択状態でないときは、カーソル位置の物理行をカットして行選択文字列として追加する。
;;; 追加した文字列をクリップボードにもコピーし、クリップボードの新規フラグをクリアする。
(defun vwcmd-cut ()
    (interactive)
    (case (get-selection-type)
        ((1 2 3)
            (kill-selection)
            (vwfunc-yank-selection-to-clipboard))
        (t
            (unless (and (eobp) (= (current-column) 0))
                (goto-column
                    (prog1
                        (current-virtual-column)
                        (let ((start (progn (goto-bol) (point)))
                              (end (progn (goto-eol) (forward-char) (point))))
                            (ed::selection-new 1 (buffer-substring start end))
                            (delete-region start end)
                            (vwfunc-yank-selection-to-clipboard))))))))

;;;.. コピー
;;; 選択範囲をコピーして、セレクションリングに追加する。
;;; バッファが選択状態でないときは、カーソル位置の物理行をコピーして行選択文字列として追加する。
;;; 追加した文字列をクリップボードにもコピーし、クリップボードの新規フラグをクリアする。
(defun vwcmd-copy ()
    (interactive)
    (case (get-selection-type)
        ((1 2 3)
            (copy-selection)
            (vwfunc-yank-selection-to-clipboard))
        (t
            (unless (and (eobp) (= (current-column) 0))
                (save-excursion
                    (let ((start (progn (goto-bol) (point)))
                          (end (progn (goto-eol) (forward-char) (point))))
                        (ed::selection-new 1 (buffer-substring start end))
                        (vwfunc-yank-selection-to-clipboard)))))))

;;;.. ポップ
;;; セレクションリングからポップする。カーソル位置は移動しない。
;;; 文字列が行選択タイプのときは物理行頭に挿入し、物理行番号と表示桁位置を保持する。
;;; クリップボードに新規データがあるときはクリップボードからペーストし、新規フラグをクリアする。
(defun vwcmd-pop ()
    (interactive)
    (stop-selection)
    (if *clipboard-newer-than-kill-ring-p*
        (goto-char
            (prog1
                (point)
                (paste-from-clipboard)
                (setq *clipboard-newer-than-kill-ring-p* nil)))
        (if *selection-ring*
            (if (= (car (car *selection-ring*)) 1)
                (let ((line (current-line-number))
                      (column (current-virtual-column)))
                    (goto-bol)
                    (yank-selection-and-pop)
                    (goto-line line)
                    (goto-column column))
                (goto-char
                    (prog1
                        (point)
                        (yank-selection-and-pop)))))))

;;;.. ペースト
;;; セレクションリングからペーストする。カーソル位置は移動しない。
;;; 文字列が行選択タイプのときは物理行頭に挿入し、物理行番号と表示桁位置を保持する。
;;; クリップボードに新規データがあるときはクリップボードからペーストする。新規フラグはクリアしない。
(defun vwcmd-paste ()
    (interactive)
    (stop-selection)
    (if *clipboard-newer-than-kill-ring-p*
        (goto-char
            (prog1
                (point)
                (paste-from-clipboard)))
        (if *selection-ring*
            (if (= (car (car *selection-ring*)) 1)
                (let ((line (current-line-number))
                      (column (current-virtual-column)))
                    (goto-bol)
                    (yank-selection)
                    (goto-line line)
                    (goto-column column))
                (goto-char
                    (prog1
                        (point)
                        (yank-selection)))))))

;;;.. 選択を開始(文字単位のみ)
;;; 文字選択モードで選択を開始する。
;;; バッファがいずれかの選択状態にあるときは、選択状態を解除する。
;;; VZ風のカーソル移動の方向による上下→行単位、左右→文字単位の切り替えは未実装。
(defun vwcmd-select ()
    (interactive)
    (case (get-selection-type)
        (1 (stop-selection))
        (2 (stop-selection))
        (3 (stop-selection))
        (t (start-selection 2))))

;;;.. 段落の二重化
;;; カーソルがある物理行の複製を作って挿入する。
(defun vwcmd-duplicate-para ()
    (interactive)
    (unless (and (eobp) (= (current-column) 0))
        (let ((line (current-line-number))
              (column (current-virtual-column))
              (str (buffer-substring
                        (progn (goto-bol) (point))
                        (progn (goto-eol) (point)))))
            (goto-bol)
            (insert str)
            (insert "\n")
            (goto-line line)
            (goto-column column))))


;;;. 検索語関連

(require "dialogs")

;;;.. 検索文字列の設定
;;; 検索は行なわずに、検索文字列とオプションの指定のみを行うダイアログ。
;;; dialogs.lとsearch.lのコードを参考に作成。
(defparameter *ui-search-set-template*
    '(dialog 0 0 242 95
        (:caption "検索文字列の設定")
        (:font 9 "MS Pゴシック")
        (:control
            (:static nil "検索(&S):" #x50020000 7 10 28 8)
            (:combobox search nil #x50210842 39 8 140 240)
            (:button case-fold "大文字小文字を区別する(&C)" #x50010006 39 27 96 10)
            (:button word "単語単位で検索する(&W)" #x50010003 39 40 83 10)
            (:button regexp "正規表現(&E)" #x50010003 39 53 52 10)
            (:button escseq "エスケープシーケンスを理解しろ(&Y)" #x50010003 39 66 117 10)
            (:button wrap "見つからなければ戻って検索(&V)" #x50010003 39 79 107 10)
            (:button IDOK "OK" #x50010001 185 7 50 14)
            (:button IDCANCEL "キャンセル" #x50010000 185 24 50 14))))

(defun vwcmd-ui-search-set ()
    (interactive)
    (multiple-value-bind (result data)
        (let ((string
                (or (selection-start-end (start end) (buffer-substring start end))
                    (if *regexp-search*
                        ed::*last-search-regexp*
                        ed::*last-search-string*))))
            (dialog-box *ui-search-set-template*
                (list
                    (cons 'search *minibuffer-search-string-history*)
                    (cons 'case-fold (ed::cfs2dialog *case-fold-search*))
                    (cons 'word *word-search*)
                    (cons 'regexp *regexp-search*)
                    (cons 'search
                        (if (eq (cdr ed::*last-search-string-pair*) string)
                            (car ed::*last-search-string-pair*)
                            string))
                    (cons 'escseq *understand-escape-sequences*)
                    (cons 'wrap *wrap-search*))
                '((word :disable (regexp))
                  (search :non-null "検索文字列を入力して" :enable (IDOK)))))
        (when result
            (let ((string (cdr (assoc 'search data))))
                (when string
                    (add-history string '*minibuffer-search-string-history*)
                    (setq *case-fold-search* (ed::dialog2cfs (cdr (assoc 'case-fold data))))
                    (setq *word-search* (cdr (assoc 'word data)))
                    (setq *regexp-search* (cdr (assoc 'regexp data)))
                    (setq *wrap-search* (cdr (assoc 'wrap data)))
                    (setq *understand-escape-sequences* (cdr (assoc 'escseq data)))
                    (if *understand-escape-sequences*
                        (setq ed::*last-search-string-pair*
                            (cons string
                                (setq string (decode-escape-sequence string *regexp-search*))))
                        (setq ed::*last-search-string-pair* nil))
                    (setq ed::*last-search-p* t)
                    (setq ed::*last-search-regexp-p* (and (null *word-search*) *regexp-search*))
                    (if ed::*last-search-regexp-p*
                        (setq ed::*last-search-regexp* string)
                        (setq ed::*last-search-string* string))
                    (message "~A" string))))))

;;; 指定した位置の単語を取得
(defun vwfunc-get-word (&optional (start (point)))
    (save-excursion
        (goto-char start)
        (if (or (eobp) (char= (char-after start) #\LFD))
            nil
            (let* ((str (buffer-substring (point) (progn (forward-word) (point))))
                   (lfd-index (position #\LFD str :test #'char=)))
                (if lfd-index
                    (substring str 0 lfd-index)
                    str)))))

;;; 検索語のヒストリに単語を追加
(defun vwfunc-add-search-string-history (new-str)
    (add-history new-str '*minibuffer-search-string-history*)
    (setq ed::*last-search-p* t)
    (setq *regexp-search* nil)
    (setq ed::*last-search-regexp-p* nil)
    (setq ed::*last-search-string* new-str)
    (message "~A" new-str))

;;;.. 検索文字列の取得
;;; カーソル位置の単語を検索文字列として記憶する。
;;; 連続実行した場合は、それまでに取得した文字列にその先の単語を連結する。
;;; 範囲選択時は、範囲内の文字列を記憶する。
(defun vwcmd-search-get ()
    (interactive)
    (case (get-selection-type)
        ((1 2 3)
            (selection-start-end (start end)
                (vwfunc-add-search-string-history (buffer-substring start end))))
        (t
            (let (prev-str (start-pnt (point)))
                (if (eq *last-command* 'vwcmd-search-get)
                    (let ((str (car *minibuffer-search-string-history*)))
                        (if (looking-for str)
                            (setq prev-str str start-pnt (+ (point) (length str))))))
                (let* ((str (vwfunc-get-word start-pnt)) (new-str (concat prev-str str)))
                    (if str
                        (progn
                            (if prev-str (pop *minibuffer-search-string-history*))
                            (vwfunc-add-search-string-history new-str))
                        (if prev-str
                            (message "~A (行末です)" prev-str)
                            (message "(行末です)"))))))))

;;;.. 検索文字列の挿入
;;; 最後に検索した文字列をカーソル位置に挿入する。
(defun vwcmd-insert-find ()
    (interactive)
    (if ed::*last-search-p*
        (insert (if ed::*last-search-regexp-p*
                    ed::*last-search-regexp*
                    ed::*last-search-string*))
        (if *minibuffer-search-string-history*
            (insert (car *minibuffer-search-string-history*)))))

;;;.. 最近検索した文字列の挿入
;;; ダイアログから最近検索した文字列を選んでカーソル位置に挿入する。
;;; 文字列の削除も可能。
(defvar *last-insert-search-string* "")

(defparameter *ui-insert-search-template*
    '(dialog 0 0 200 200
        (:caption "最近検索した文字列の挿入")
        (:font 9 "MS Pゴシック")
        (:control
            (:listbox strlist nil #x50b10001 4 4 138 192)
            (:button IDOK "OK" #x50010001 146 4 50 14)
            (:button delete "削除(&D)" #x50010000 146 21 50 14)
            (:button IDCANCEL "キャンセル" #x50010000 146 38 50 14))))

(defun vwcmd-ui-insert-search ()
    (interactive)
    (let ((last-position))
        (loop
            (multiple-value-bind (result data)
                (dialog-box *ui-insert-search-template*
                    (list
                        (cons 'strlist *minibuffer-search-string-history*)
                        (cons 'strlist
                            (or
                                last-position
                                (position *last-insert-search-string*
                                          *minibuffer-search-string-history*
                                          :test #'string=)
                                0)))
                    '((strlist :must-match t :enable (IDOK delete))))
                (cond ((eq result 'IDOK)
                            (setq *last-insert-search-string* (cdr (assoc 'strlist data)))
                            (insert *last-insert-search-string*)
                            (add-history *last-insert-search-string* '*minibuffer-search-string-history*)
                            (return))
                      ((eq result 'delete)
                            (let ((str (cdr (assoc 'strlist data))))
                                (setq last-position (position str *minibuffer-search-string-history*
                                                              :test #'string=))
                                (setq *minibuffer-search-string-history*
                                    (delete str *minibuffer-search-string-history* :test #'string=))
                                (if (and
                                        (>= last-position (length *minibuffer-search-string-history*))
                                        (> last-position 0))
                                    (decf last-position))))
                      (t
                            (return)))))))


;;;. マーク・ジャンプ関連

(defparameter *mark-max* 5)
(defvar-local *mark-data* nil)

;;; 指定した番号のマークに現在位置を記憶
(defun vwfunc-mark (number)
    (if (null *mark-data*)
        (setq *mark-data* (make-vector *mark-max*)))
    (setf (svref *mark-data* number) (point-marker))
    (message "マーク #~A" number))

;;; 指定した番号のマークを取得
(defun vwfunc-get-mark (number)
    (let ((marker))
        (if (or
                (null *mark-data*)
                (null (setq marker (svref *mark-data* number))))
            nil
            marker)))

;;; 指定した番号のマークの位置へジャンプ
(defun vwfunc-jump-mark (number)
    (let ((marker (vwfunc-get-mark number)))
        (if marker
            (progn
                (goto-marker marker)
                (message "ジャンプ #~A" number))
            (message "#~Aにはマークされていません" number))))

;;;.. マーク0(直前位置を記憶する場所)に記憶
;;; 直前にいた位置を記憶しておくコマンド。
;;; 直接実行、あるいは以下のジャンプコマンドのように移動操作などの前に実行しておくことで、
;;; 次の「直前位置へ戻る」コマンドで元の位置へ戻ることができる。
;;; 実行タイミングの例としては、下記の文書先頭/末尾へのジャンプ時や、指定行への移動時、
;;; アウトラインの開閉時などがある。
(defun vwcmd-mark-cur ()
    (interactive)
    (vwfunc-mark 0))

;;;.. 直前位置へ戻る
;;; 現在のカーソル位置をマーク0に記憶し、もとのマーク0の位置へジャンプする。
;;; マーク0に位置が記憶されていなかった場合は、文書の先頭へジャンプする。
(defun vwcmd-jump-mark-cur ()
    (interactive)
    (let ((marker (vwfunc-get-mark 0)))
        (vwcmd-mark-cur)
        (if marker
            (progn
                (goto-marker marker)
                (message "ジャンプ #0"))
            (goto-char (point-min)))))

;;;.. マーク(しおり)1〜4に記憶
(defun vwcmd-mark1 ()
    (interactive)
    (vwfunc-mark 1))

(defun vwcmd-mark2 ()
    (interactive)
    (vwfunc-mark 2))

(defun vwcmd-mark3 ()
    (interactive)
    (vwfunc-mark 3))

(defun vwcmd-mark4 ()
    (interactive)
    (vwfunc-mark 4))

;;;.. マーク(しおり)1〜4の位置へジャンプ
(defun vwcmd-jump-mark1 ()
    (interactive)
    (vwcmd-mark-cur)
    (vwfunc-jump-mark 1))

(defun vwcmd-jump-mark2 ()
    (interactive)
    (vwcmd-mark-cur)
    (vwfunc-jump-mark 2))

(defun vwcmd-jump-mark3 ()
    (interactive)
    (vwcmd-mark-cur)
    (vwfunc-jump-mark 3))

(defun vwcmd-jump-mark4 ()
    (interactive)
    (vwcmd-mark-cur)
    (vwfunc-jump-mark 4))

;;;.. 文書の先頭へ
(defun vwcmd-jump-file-top ()
    (interactive)
    (vwcmd-mark-cur)
    (goto-char (point-min)))

;;;.. 文書の末尾へ
(defun vwcmd-jump-file-end ()
    (interactive)
    (vwcmd-mark-cur)
    (goto-char (point-max))
    (recenter -1))

;;; 指定した番号のマークからマークダイアログ表示用のエントリーを作成
(defun vwfunc-make-mark-entry (number)
    (let ((marker (vwfunc-get-mark number))
          (entry))
        (push (buffer-name (selected-buffer)) entry)
        (push (format nil "#~A" number) entry)
        (if (null marker)
            (progn
                (push "" entry)
                (push "- no mark -" entry))
            (save-excursion
                (goto-marker marker)
                (push (current-line-number) entry)
                (push (buffer-substring (point)
                                        (progn (goto-eol) (point)))
                      entry)))
        (nreverse entry)))

;;; マークダイアログ表示用のエントリーリストを作成
(defun vwfunc-make-mark-list ()
    (let ((result))
        (dolist (b (buffer-list :buffer-bar-order t))
            (if (char/= #\SPC (char (buffer-name b) 0))
                (save-excursion
                    (set-buffer b)
                    (do ((i 1 (1+ i)))
                            ((>= i *mark-max*))
                        (push (vwfunc-make-mark-entry i) result)))))
        (nreverse result)))

;;;.. マーク(しおり)ダイアログ
;;; 全バッファのマーク内容を表示するグローバル版。
;;; マーク項目を選択すると、位置データが記憶されていればその位置へジャンプする。
(defparameter *ui-mark-template*
    '(dialog 0 0 300 200
        (:caption "しおり")
        (:font 9 "MS Pゴシック")
        (:control
            (:listbox marklist nil #x50b10011 4 4 236 192)
            (:button IDOK "OK" #x50010001 244 4 50 14)
            (:button IDCANCEL "キャンセル" #x50010000 244 21 50 14))))

(defun vwcmd-ui-mark ()
    (interactive)
    (let ((mark-list (vwfunc-make-mark-list)))
        (multiple-value-bind (result data)
            (dialog-box *ui-mark-template*
                (list (cons 'marklist mark-list)
                      (cons 'marklist (find (buffer-name (selected-buffer)) mark-list :key #'car)))
                `((marklist :column (,(apply #'max (mapcar #'(lambda (x) (length (car x))) mark-list))
                                     4 -6 128)
                        :must-match t
                        :enable (IDOK))))
            (when result
                (let* ((entry (cdr (assoc 'marklist data)))
                       (buffer (find-buffer (nth 0 entry)))
                       (number (parse-integer (nth 1 entry) :start 1)))
                    (when (not (equal (nth 2 entry) ""))
                        (set-buffer buffer)
                        (vwcmd-mark-cur)
                        (goto-marker (vwfunc-get-mark number))))))))


;;;. プロファイル関連

(define-history-variable *profile-list* nil)
(defparameter *profile-list-max* 200)

;;; すべてのマークの位置を取得
(defun vwfunc-get-mark-points ()
    (if *mark-data*
        (do ((i 0 (1+ i)) (points))
                ((>= i *mark-max*) (nreverse points))
            (let ((m (svref *mark-data* i)))
                (push (if m (marker-point m) nil) points)))))

;;; すべてのマークに位置を設定
(defun vwfunc-set-mark-points (points)
    (when points
        (if (null *mark-data*)
            (setq *mark-data* (make-vector *mark-max*)))
        (let ((i 0))
            (dolist (p points)
                (setf (svref *mark-data* i)
                    (if p
                        (let ((marker))
                            (setq marker (make-marker))
                            (set-marker marker p)
                            marker)
                        nil))
                (incf i)
                (if (>= i *mark-max*) (return))))))

;;;.. プロファイルの保存
;;; ファイルを閉じるとき、そのファイルのプロファイルを保存する。
;;; ただし簡易版で、記憶するのはカーソル位置、カーソルY座標、しおり(マーク)の位置のみ。
(defun vwfunc-save-profile (buffer)
    (let ((filename (get-buffer-file-name buffer)))
        (if filename
            (let ((item (assoc filename *profile-list* :test #'string=)))
                (if item
                    (setq *profile-list* (delete item *profile-list*)))
                (save-excursion
                    (set-buffer buffer)
                    (push (list filename
                                (point)
                                (- (current-virtual-line-number) (get-window-start-line))
                                (vwfunc-get-mark-points))
                          *profile-list*))
                (let ((len (length *profile-list*)))
                    (if (> len *profile-list-max*)
                        (setq *profile-list*
                            (nbutlast *profile-list* (- len *profile-list-max*))))))))
    t)

(add-hook '*before-delete-buffer-hook* 'vwfunc-save-profile)

;;;.. プロファイルの復元
;;; ファイルを開いたとき、そのファイルのプロファイルがあれば復元する。
(defun vwfunc-load-profile ()
    (let ((item (assoc (get-buffer-file-name) *profile-list* :test #'string=)))
        (if item
            (let ((point (nth 1 item))
                  (y     (nth 2 item))
                  (mp    (nth 3 item)))
                (goto-char point)
                (recenter y)
                (vwfunc-set-mark-points mp)))))

(add-hook '*find-file-hooks* 'vwfunc-load-profile)


Copyright©2009 Kiichiro Kawano All rights reserved.
E-mail:k-kawano@mail.707.to
最終更新日:2009/03/19(Thu)