これも、バックアップとして置いておく。
discrete.l - 小さなコマンド群
;;; ;;; discrete.l ;;; (require "lib") (provide "discrete") ;;; ;;; binding to test lisp code ;;; (defun test-call () (interactive) (test)) (defun test () (dbg-msgbox 'dummy-test)) (global-set-key #\M-\2 'test-call) ;;; pt (defun pt () (interactive) (message "~D" (point))) ;;; ;;; main menu ;;; (defun popup-app-menu () (interactive) (let ((menu (copy-menu-items *app-menu* (create-popup-menu)))) (track-popup-menu menu))) (global-set-key #\RBtnUp 'popup-app-menu) ;;; ;;; next-page, previous-page ;;; (defun next-page-gnrr () (interactive) (let ((end-line (+ (get-window-start-line) (window-lines)))) (next-page) (when (> end-line (buffer-lines)) (goto-char (point-max))))) (global-set-key #\M-n 'next-page-gnrr) (defun previous-page-gnrr () (interactive) (let ((start-line (get-window-start-line))) (previous-page) (when (= start-line 1) (goto-char (point-min))))) (global-set-key #\M-p 'previous-page-gnrr) ;;; ;;; comment-region ;;; (defun comment-region () (interactive) (comment-out-region)) ;;; ;;; toggle-truncate-lines ;;; (defun toggle-truncate-lines (&optional dir) (interactive "p") (let* ((table `((nil . "折り返し: なし") (t . "折り返し: ウィンドウ幅") ;(,buffer-fold-widhth . "指定位置で折り返し")))) )) (current (nth (mod (+ (position (buffer-fold-width) table :test (lambda (x y) (eql x (car y)))) (if dir 1 -1)) (length table)) table))) (set-buffer-fold-width (car current)) (message (cdr current)))) (global-set-key '(#\C-x #\t) 'toggle-truncate-lines) ; C-x t ;;; ;;; toggle-narrowing-region ;;; (defvar-local *narrowing-region-state* nil) (defun toggle-narrowing-region () (interactive) (flet ((mark-beg () (let ((mk (mark t))) (if mk mk 0)))) (if *narrowing-region-state* (widen) (narrow-to-region (mark-beg) (point)))) (setq *narrowing-region-state* (not *narrowing-region-state*))) (global-set-key '(#\C-x #\n #\n) 'toggle-narrowing-region) (global-unset-key '(#\C-x #\n #\w)) ;;領域外の色は Windows のシステムカラーの使用不可の項目 ;;; ;;; count-line ;;; (defun count-line (from to) (interactive "*r") (let (beg end cnt) (save-excursion (setq beg (progn (goto-char from) (current-line-number))) (setq end (progn (goto-char to) (current-line-number)))) (setq cnt (abs (- beg end))) (if (interactive-p) (message "count line: ~D" cnt) cnt))) ;;; ;;; todo ;;; (defvar todo-file "~/todo.txt") (defun todo () (interactive) (find-file todo-file)) ;;; ;;; find-file-gnrr ;;; (defun find-file-gnrr (fn) (interactive "FFind file: ") (cond ((file-exist-p fn) (find-file fn)) ((y-or-n-p "new file? ") (find-file fn)))) (define-key ctl-x-map #\C-\f 'find-file-gnrr) ;;; ;;; cmd.exe ;;; (defun c () (interactive) (let* ((fn (get-buffer-file-name)) (ed::*launch-app-directory* (if fn (directory-namestring fn) (si:system-root)))) (run-console))) ;;; ;;; explorer.exe ;;; (defun open-explorer (fn) (flet ((get-arg () (if fn (concat "/e,/select," (map-slash-to-backslash fn)) (concat "/e," (map-slash-to-backslash (si:system-root)))))) (call-process (concat (get-windows-directory) "explorer " (get-arg))))) (defun e () (interactive) (let ((fn (get-buffer-file-name))) (cond ((null fn) (open-explorer nil)) ((file-exist-p fn) (open-explorer fn)) (t (message "not exist ~A" fn))))) ;;; ;;; hatena-insert ;;; (defvar *hatena-insert-alist* '((">|lisp|\n||<" . "スーパー pre lisp") ;(">||\n||<" . "スーパー pre") ("[:title=ココ]" . "リンク") ("<br>" . "改行") ("(())" . "脚注") (">>\n<<" . "引用") ;("-" . "リスト") ;("+" . "リスト 番号つき") ("**" . "小見出し") ("><hr><" . "区切り線"))) (defvar *hatena-insert-last-num* 0) (defun hatena-insert () (interactive) (let ((lst *hatena-insert-alist*)) (setq *hatena-insert-last-num* (if (eq *last-command* 'hatena-insert) (progn (delete-char (1+ (length (car (nth *hatena-insert-last-num* lst))))) ;(delete-char (length (car (nth *hatena-insert-last-num* lst)))) (mod (incf *hatena-insert-last-num*) (length *hatena-insert-alist*))) 0)) (let ((e (nth *hatena-insert-last-num* lst))) (save-excursion (insert (car e) "\n")) ;(save-excursion (car e)) (message "~D/~D ~A" (1+ *hatena-insert-last-num*) (length *hatena-insert-alist*) (cdr e))))) (global-set-key #\M-3 'hatena-insert) ;;; ;;; trace ;;; http://www.geocities.jp/kiaswebsite/xyzzy/encap.html ; (trace function1 function2 ...) makes the functions `traced'. ; (trace) returns `traced' functions. ; (untrace function1 function2 ...) makes the functions `untraced'. ; (untrace) makes all `traced' functions `untraced'. (require "encap") (defvar *trace-function-list* nil) (defvar *trace-depth* 0) (defun trace-encap (func) (unless (encapsulated-p func 'traced-function) (encapsulate func 'traced-function `( ;(ed::setup-trace-output-buffer) (setq *trace-depth* (1+ *trace-depth*)) ;(format *error-output* "~ACalling ~S~%" (make-sequence 'string *trace-depth* :initial-element #\SPC) (cons ',func argument-list)) (format t "~ACalling ~S~%" (make-sequence 'string *trace-depth* :initial-element #\SPC) (cons ',func argument-list)) (let ((#1=#:result (multiple-value-list (apply basic-definition argument-list)))) ;(format *error-output* "~A~S returned~{ ~A~}~%" (make-sequence 'string *trace-depth* :initial-element #\SPC) ',func #1#) (format t "~A~S returned~{ ~A~}~%" (make-sequence 'string *trace-depth* :initial-element #\SPC) ',func #1#) (setq *trace-depth* (1- *trace-depth*)) (values-list #1#)))) (push func *trace-function-list*) func)) (defun trace-unencap (func) (when (encapsulated-p func 'traced-function) (unencapsulate func 'traced-function) (setq *trace-function-list* (remove func *trace-function-list* :test #'eq)) func)) (defmacro trace (&rest args) (setq *trace-depth* 0) ; add (if (null args) '*trace-function-list* `(let (lst) (dolist (func ',args (reverse lst)) (when (trace-encap func) (setq lst (cons func lst))))))) (defmacro untrace (&rest args) (if (null args) '(let (lst) (dolist (func *trace-function-list* lst) (when (trace-unencap func) (setq lst (cons func lst))))) `(let (lst) (dolist (func ',args (reverse lst)) (when (trace-unencap func) (setq lst (cons func lst))))))) ;;; ;;; 行を複製(二重化)する ;;; (defun replica-line () (interactive "*") (save-excursion (insert (buffer-substring (progn (goto-eol) (point)) (progn (goto-bol) (point)))) (newline))) (global-set-key #\M-\= 'replica-line) ;;; ;;; windows のクリップボードと kill-ring を同期させる ;;; ;;synclonize clipboad and kill-ring (defun copy-selection-region-to-clipboard () (interactive) (setq is-selected nil) (if (and *shodat-copy-mode* (pre-selection-p)) (let ((type (get-selection-type))) (selection-start-end (start end) (copy-region-as-kill start end) (copy-region-to-clipboard start end) (setq is-selected t) (start-selection type t end))) (selection-start-end (start end) (copy-region-as-kill start end) (copy-region-to-clipboard start end) (setq is-selected t))) (if (eq is-selected nil) (progn (copy-region-as-kill (mark) (point)) (copy-region-to-clipboard (mark) (point)))) t) (defun kill-selection-region-to-clipboard () (interactive "*") (setq is-selected nil) (selection-start-end (start end) (copy-region-as-kill start end) (kill-region-to-clipboard start end) (setq is-selected t)) (if (eq is-selected nil) (progn (copy-region-as-kill (mark) (point)) (kill-region-to-clipboard (mark) (point)))) t) (defun kill-line-to-clipboard () "kill line to clipboard" (interactive) (setq kill-line-to-clipboard-start (point)) (end-of-line) (if (eq kill-line-to-clipboard-start (point)) (delete-char) (progn (copy-region-as-kill kill-line-to-clipboard-start (point)) (kill-region-to-clipboard kill-line-to-clipboard-start (point))))) (define-key *global-keymap* #\C-w 'kill-selection-region-to-clipboard ) (define-key *global-keymap* #\M-w 'copy-selection-region-to-clipboard ) (define-key *global-keymap* #\C-y 'paste-from-clipboard ) (define-key *global-keymap* #\C-k 'kill-line-to-clipboard ) ;;; ;;; M-x help でリファレンスを開く ;;; (defun help () (interactive) (let ((chm "reference.chm")) (shell-execute (concat (si::system-root) "etc/" chm)))) ;;; ;;; execute-extended-command ;;; http://d.hatena.ne.jp/x68kace/20080317/p2 ; M-x で入力したコマンドにショートカットキーがあれば教える (defun execute-extended-command (command &optional raw arg) (interactive "0CM-x: \nP\np") (let ((*prefix-args* raw) (*prefix-value* arg)) (setq *last-complex-command* nil) (setq *this-command* command) (command-execute command (and (interactive-p) (not *executing-macro*) #'ed::record-complex-command)) ;ここから上書き (let ((global (command-keys command *global-keymap* nil)) (local (command-keys command *global-keymap* (local-keymap))) (minor (command-keys command *global-keymap* (local-keymap) (minor-mode-map)))) (when minor (message "You can run the command '~A' with ~S (~A)" command (key-to-string (car minor)) (cond (global "global") (local "local") (t "minor"))) (sit-for 3))))) ;;; ;;; comment-line-and-next-line ;;; (require "comment") ;; http://hie.s64.xrea.com/xyzzy/note/edit.html#toggle-one-line-comment (defvar *one-line-comment-alist* '((awk-mode . ("#")) (css-mode . ("/* " " */")) (c-mode . ("/* " " */")) ; mod (html+-mode . ("<!-- " " -->")) (lisp-mode . (";")) (lisp-interaction-mode . (";")) (perl-mode . ("#")) (php-mode . ("//")) (sql-mode . ("--")))) (defun toggle-one-line-comment () ; (interactive) ; mod (let ((li (cdr (assoc buffer-mode *one-line-comment-alist*))) bol eol str keyreg) (when li (save-excursion (goto-eol) (setq eol (point)) (back-to-indentation) (setq bol (point)) (setq str (buffer-substring bol eol)) (if (= (length li) 1) (let ((key (car li))) (setq keyreg (format nil "^~A+[ \t]*" (regexp-quote key))) (if (string-match keyreg str) (delete-region (+ bol (match-beginning 0)) (+ bol (match-end 0))) (progn (back-to-indentation) (insert key)))) (let ((key1 (car li)) (key2 (cadr li))) (setq keyreg (format nil "^\\(~A\\)+[ \t]*\\(.*\\)[ \t]*\\(~A\\)+$" (regexp-quote key1) (regexp-quote key2))) (if (string-match keyreg str) (progn (setq str (string-replace-match str "\\2")) (delete-region (+ bol (match-beginning 0)) (+ bol (match-end 0))) (insert str)) (progn (back-to-indentation) (insert key1) (goto-eol) (insert key2))))))))) ;; add (defun comment-line-and-next-line () (interactive) (toggle-one-line-comment) (next-line)) (global-set-key #\M-\; 'comment-line-and-next-line) ;;; ;;; indent-for-comment-gnrr ;;; (defun indent-for-comment-gnrr (&optional arg) (interactive "p") (if arg ;; set-comment-column (let ((col (current-column))) (setq comment-column col) (message "set comment-column to ~D." col)) (indent-for-comment))) (global-set-key #\C-\; 'indent-for-comment-gnrr) ;;; ;;; isearch-forward-gnrr ;;; use regexp or fixed string in isearch ;;; (defun isearch-forward-gnrr (&optional re) (interactive "p") (setq *isearch-scanner-hook* #'(lambda (p) (setq ed::*isearch-regexp* (if re t nil)) p)) (call-interactively 'isearch-forward)) (defun isearch-backward-gnrr (&optional re) (interactive "p") (setq *isearch-scanner-hook* #'(lambda (p) (setq ed::*isearch-regexp* (if re t nil)) p)) (call-interactively 'isearch-backward)) (global-set-key #\C-s 'isearch-forward-gnrr) (global-set-key #\C-r 'isearch-backward-gnrr) ;;; use regexp or fixed string in query-replace (defun query-replace-gnrr (&optional re) (interactive "p") (if re (call-interactively 'query-replace-regexp) (call-interactively 'query-replace))) (global-set-key #\M-% 'query-replace-gnrr) ;;; ;;; ミニバッファに入ったとき IME を OFF にする ;;; (export '(*ime-mode-into-minibuffer*)) (defvar *ime-mode-into-minibuffer* nil) (defun ime-state-get-and-setoff (bef-buffer file-name) (interactive) (setq *ime-mode-into-minibuffer* (get-ime-mode)) (toggle-ime nil)) (defun ime-state-set (bef-buffer file-name) (interactive) (toggle-ime *ime-mode-into-minibuffer*)) (add-hook '*enter-minibuffer-hook* 'ime-state-get-and-setoff) (add-hook '*exit-minibuffer-hook* 'ime-state-set) ;;; ;;; find-file-frequently ;;; (defvar *find-file-frequently-list* '((merge-pathnames ".xyzzy" (user-homedir-pathname)) (append-trail-slash (path-delim-to-slash (get-special-folder-location :desktop))) (default-directory))) (defvar *find-file-frequently-count* 0) (add-hook '*enter-minibuffer-hook* #'(lambda (buf his) (setq *find-file-frequently-count* 0))) (defun find-file-frequently-sort-function (x y) (cond ((and (not (file-directory-p x)) (file-directory-p y)) t) ((and (file-directory-p x) (not (file-directory-p y))) nil) (t (string-length-lessp x y)))) (defun find-file-frequently () (interactive) (let ((old (buffer-substring (point-min) (point-max))) (lst (mapcar #'truename-mod (mapcar #'eval *find-file-frequently-list*)))) (let ((s (nth (mod *find-file-frequently-count* (length lst)) (sort lst #'find-file-frequently-sort-function)))) (if (or (string= s old) (find s (mapcar #'get-buffer-file-name (buffer-list)) :test 'string=)) (progn (incf *find-file-frequently-count*) (find-file-frequently)) (progn (delete-region (point-min) (point-max)) (insert s) (incf *find-file-frequently-count*)))))) (define-key ed::minibuffer-local-completion-map #\C-\f #'(lambda () (interactive) (if (= (point) (point-max)) (find-file-frequently) (forward-char 1)))) (setq *find-file-frequently-list* (append *find-file-frequently-list* '("~/lisp/"))) ;;; ;;; my-just-one-space ;;; (defvar my-just-one-space-state t) (make-local-variable 'my-just-one-space-state) (defun my-just-one-space () (interactive) (if (and (eq *last-command* 'my-just-one-space) (eq my-just-one-space-state nil)) (delete-backward-char 1) (just-one-space)) (setq my-just-one-space-state (not my-just-one-space-state))) (global-set-key #\M-SPC 'my-just-one-space) ;;; ;;; kill-buffer-gnrr ;;; (defun kill-buffer-gnrr () (interactive) (kill-buffer (selected-buffer))) (global-set-key '(#\C-x #\k) 'kill-buffer-gnrr) ;;; ;;; eval-buffer mod ;;; (defvar eval-buffer-orig nil) (unless (functionp eval-buffer-orig) (setq eval-buffer-orig (function eval-buffer))) (defun eval-buffer (&optional buf) (interactive) (if (interactive-p) (funcall eval-buffer-orig (selected-buffer)) (funcall eval-buffer-orig buf))) ;(eval-buffer (selected-buffer)) と書かれてるバッファで C-j すると無限ループになる ; そんなときは C-g すべし(コメントにしとけば問題なし) ;;; ;;; insert () ;;; (defun insert-paired-paren () (interactive) (insert "()") (forward-char -1)) (global-set-key #\M-9 'insert-paired-paren) ;;; ;;; insert [] or {} ;;; (defvar *insert-paired-bracket-state* nil) (defun insert-paired-bracket () (interactive) (let ((br "[]") (cbr "{}")) (when (eq *last-command* 'insert-paired-bracket) (forward-char -1) (delete-char 2)) (if *insert-paired-bracket-state* (insert cbr) (insert br)) (forward-char -1)) (setq *insert-paired-bracket-state* (not *insert-paired-bracket-state*))) (global-set-key #\M-\[ 'insert-paired-bracket) ;;; ;;; insert '' or "" ;;; (defvar *insert-paired-quote-state* nil) (defun insert-paired-quote () (interactive) (let ((sq "\'\'") (dq"\"\"")) (when (eq *last-command* 'insert-paired-quote) (forward-char -1) (delete-char 2)) (if *insert-paired-quote-state* (insert dq) (insert sq)) (forward-char -1)) (setq *insert-paired-quote-state* (not *insert-paired-quote-state*))) (global-set-key #\M-\' 'insert-paired-quote) ;;; ;;; jump-to-paren ;;; (defun jump-to-paren () "jump to the matching parenthesis if on parenthesis." (interactive) (cond ((looking-at "[([{]") (forward-sexp 1)) ((save-excursion (forward-char -1) (looking-at "[])}]")) (backward-sexp 1)) ((looking-at "[])}]") (forward-char) (backward-sexp 1)) (t nil))) (global-set-key #\M-\] 'jump-to-paren) ;;; ;;; undo-redo ;;; (defun undo-redo-gnrr (&optional arg) (interactive "p") (if arg (redo) (undo))) (global-set-key #\C-z 'undo-redo-gnrr) ;;; ;;; save-buffer-gnrr ;;; (defun write-file-tmp (fn) (interactive "FWrite: " :default0 (concat (append-trail-slash (path-delim-to-slash (get-special-folder-location :desktop))) (substitute-string (buffer-name (selected-buffer)) "[* ]" "") "_")) (write-file fn)) (defun save-buffer-gnrr () (interactive) (if (get-buffer-file-name) (call-interactively 'save-buffer) (call-interactively 'write-file-tmp))) (global-set-key '(#\C-x #\C-\s) 'save-buffer-gnrr) ;;; discrete.l ends here