discrete.l 小コマンド群

これも、バックアップとして置いておく。

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