これも、バックアップとして置いておく。
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: "
(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
0 コメント :
コメントを投稿