discrete.l 小コマンド群


discrete.l - 小さなコマンド群

;;; discrete.l
(require "lib")
(provide "discrete")

;;; binding to test lisp code
(defun test-call ()

(defun test ()
(dbg-msgbox 'dummy-test))

(global-set-key #\M-\2 'test-call)

;;; pt
(defun pt ()
(message "~D" (point)))

;;; main menu
(defun popup-app-menu ()
(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 ()
(let ((end-line (+ (get-window-start-line) (window-lines))))
(when (> end-line (buffer-lines))
(goto-char (point-max)))))

(global-set-key #\M-n 'next-page-gnrr)

(defun previous-page-gnrr ()
(let ((start-line (get-window-start-line)))
(when (= start-line 1)
(goto-char (point-min)))))

(global-set-key #\M-p 'previous-page-gnrr)

;;; comment-region
(defun comment-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))
(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 ()
(flet ((mark-beg ()
(let ((mk (mark t)))
(if mk mk 0))))
(if *narrowing-region-state*
(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)
(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)

;;; todo
(defvar todo-file "~/todo.txt")

(defun todo ()
(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 ()
(let* ((fn (get-buffer-file-name))
(ed::*launch-app-directory* (if fn (directory-namestring fn)

;;; 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))))))
(concat (get-windows-directory) "explorer " (get-arg)))))

(defun e ()
(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 ()
(let ((lst *hatena-insert-alist*))
(setq *hatena-insert-last-num*
(if (eq *last-command* 'hatena-insert)
(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*)))
(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
(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*)

(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))

(defmacro trace (&rest args)
(setq *trace-depth* 0) ; add
(if (null args)
`(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 "*")
(insert (buffer-substring (progn (goto-eol) (point))
(progn (goto-bol) (point))))

(global-set-key #\M-\= 'replica-line)

;;; windows のクリップボードと kill-ring を同期させる
;;synclonize clipboad and kill-ring
(defun copy-selection-region-to-clipboard ()
(setq is-selected nil)
(if (and *shodat-copy-mode*
(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)
(copy-region-as-kill (mark) (point))
(copy-region-to-clipboard (mark) (point))))

(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)
(copy-region-as-kill (mark) (point))
(kill-region-to-clipboard (mark) (point))))

(defun kill-line-to-clipboard ()
"kill line to clipboard"
(setq kill-line-to-clipboard-start (point))
(if (eq kill-line-to-clipboard-start (point))
(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 ()
(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*)
(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)"
(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
(setq eol (point))
(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)))
(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)
(setq str (string-replace-match str "\\2"))
(delete-region (+ bol (match-beginning 0))
(+ bol (match-end 0)))
(insert str))
(back-to-indentation) (insert key1)
(goto-eol) (insert key2)))))))))

;; add
(defun comment-line-and-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))

(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)
(setq *ime-mode-into-minibuffer* (get-ime-mode))
(toggle-ime nil))

(defun ime-state-set (bef-buffer file-name)
(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)))

(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 ()
(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=))
(incf *find-file-frequently-count*)
(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))
(forward-char 1))))

(setq *find-file-frequently-list* (append *find-file-frequently-list*

;;; my-just-one-space
(defvar my-just-one-space-state t)
(make-local-variable 'my-just-one-space-state)

(defun my-just-one-space ()
(if (and (eq *last-command* 'my-just-one-space)
(eq my-just-one-space-state nil))
(delete-backward-char 1)
(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 ()
(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)
(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 ()
(insert "()")
(forward-char -1))

(global-set-key #\M-9 'insert-paired-paren)

;;; insert [] or {}
(defvar *insert-paired-bracket-state* nil)
(defun insert-paired-bracket ()
(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 ()
(let ((sq "\'\'")
(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."
(cond ((looking-at "[([{]") (forward-sexp 1))
(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

(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 ()
(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

Related Posts Plugin for WordPress, Blogger...

0 コメント :