path: root/common.el

;;; common.el --- Some common functions -*- lexical-binding: t; -*-

;;;###autoload
(defun center-string-in-width (str width)
  "Add spaces to STR so that it is centered in a box which is WIDTH wide."
  (let ((len (length str)))
    (cond
     ((> len width)
      (error "String %s longer than %d" str width))
     (t (format "%s%s"
                (make-string (round (- width len) 2)
                             32)
                str)))))

;;; jump between the completions buffer and the minibuffer

;;;###autoload
(defvar durand-completion-buffer-names (list "Completions"
                                             "Embark Collect"
                                             "comb")
  "The list of names that match the names of \"completion buffers\".")

;;;###autoload
(defun durand-focus-completion-or-minibuffer (&optional arg)
  "Jump between the completions buffer and the minibuffer."
  (interactive "P")
  (let* ((completion-windows
          (delq nil
                (mapcar
                 (lambda (w)
                   (and (consp
                         (delq nil
                               (mapcar (lambda (name)
                                         (string-match-p
                                          name
                                          (buffer-name (window-buffer w))))
                                       durand-completion-buffer-names)))
                        w))
                 (window-list nil 'nomini))))
         (in-completion-p (consp
                           (delq nil
                                 (mapcar
                                  (lambda (name)
                                    (string-match-p name (buffer-name)))
                                  durand-completion-buffer-names))))
         (minibuffer-active-p (active-minibuffer-window))
         (in-minibuffer-p (minibuffer-window-active-p (selected-window))))
    (cond
     ((and minibuffer-active-p
           (not in-minibuffer-p))
      (select-window (active-minibuffer-window)))
     ((and (consp completion-windows)
           (not in-completion-p))
      (select-window (car completion-windows)))
     (t
      (other-window 1)))))

;;;###autoload
(defun durand-embark-scroll-down-or-go-to-completions (&optional arg)
  "Scroll down; if this is not feasible, go to the completions buffer.
ARG means do this command ARG times."
  (interactive "p")
  (let ((original-point (point))
        (left (abs (forward-line arg)))
        (completion-windows
         (delq nil
               (mapcar
                (lambda (w)
                  (and (consp
                        (delq nil
                              (mapcar (lambda (name)
                                        (string-match-p
                                         name
                                         (buffer-name (window-buffer w))))
                                      durand-completion-buffer-names)))
                       w))
                (window-list nil 'nomini))))
        (in-completion-p (consp
                          (delq nil
                                (mapcar
                                 (lambda (name)
                                   (string-match-p name (buffer-name)))
                                 durand-completion-buffer-names)))))
    (cond ((= (point) (point-max))
           (setq left (1+ left)))
          ((get-text-property (point) 'field)
           (goto-char original-point)))
    (cond ((and (> left 0)
                (consp completion-windows)
                (not in-completion-p))
           (select-window (car completion-windows))
           (cond
            ((> arg 0)
             (goto-char (point-min))
             (cond
              ((derived-mode-p 'completion-list-mode)
               (next-completion 1))))
            ((< arg 0)
             (goto-char (point-max))
             (cond
              ((derived-mode-p 'completion-list-mode)
               (next-completion -1)))))))))

;;;###autoload
(defun durand-embark-scroll-up-or-go-to-completions (&optional arg)
  "Scroll up; if this is not feasible, go to the completions buffer.
ARG means do this command ARG times."
  (interactive "p")
  (durand-embark-scroll-down-or-go-to-completions (- arg)))

;;;###autoload
(defun durand-completion-scroll-down-or-go-to-minibuffer (&optional arg)
  "Scroll down; if this is not feasible, go to the mini-buffer.
ARG means do this command ARG times."
  (interactive "p")
  (let ((original-point (point))
        (left (abs (forward-line arg)))
        (minibuffer-active-p (active-minibuffer-window))
        (in-minibuffer-p (minibuffer-window-active-p (selected-window))))
    (cond ((= (point) (point-max))
           (setq left (1+ left)))
          ((get-text-property (point) 'field)
           (goto-char original-point)))
    (cond ((and (> left 0)
                minibuffer-active-p
                (not in-minibuffer-p))
           (select-window (active-minibuffer-window))
           (cond
            ((> arg 0)
             (goto-char (point-min)))
            ((< arg 0)
             (goto-char (point-max))))))))

;; This can be optimized by not duplicating an element on the stack.

;;;###autoload
(fset 'durand-display-in-one-window
      (make-byte-code
       #x202
       (unibyte-string 192 193 194 32 33 33 195 1 4 34 136 196 1 33 136 197 32 136 135)
       (vector 'split-window 'frame-root-window 'selected-frame
               'set-window-buffer 'select-window 'delete-other-windows)
       9
       "Display BUFFER in one window.
ALIST is an association list of action symbols and values. See
Info node `(elisp) Buffer Display Action Alists' for details of
such alists. 

This function pops up a new window and then deletes all other
windows. And ALIST is completely ignored.

\(fn BUFFER ALIST)"))

;;;###autoload
(defvar durand-window-max-height 0.3
  "Maximal height of the bottom window.
The window is placed at the bottom.")

;;;###autoload
(defun durand-fit-window-to-buffer-with-max (window)
  "Fit WINDOW to its buffer.
This is a thin wrapper around `fit-window-to-buffer'. It passes
the window to the function with max-height equal to
`durand-window-max-height'."
  (fit-window-to-buffer window
                        (floor
                         (* durand-window-max-height
                            (frame-height (window-frame window))))))

;; (defun durand-display-in-one-window (buffer _alist)
;;   "Display BUFFER in one window.
;; ALIST is an association list of action symbols and values. See
;; Info node `(elisp) Buffer Display Action Alists' for details of
;; such alists. 

;; This function pops up a new window and then deletes all other
;; windows. And ALIST is completely ignored."
;;   (let ((window (split-window (frame-root-window (selected-frame)))))
;;     (set-window-buffer window buffer)
;;     (select-window window)
;;     (delete-other-windows)
;;     window))

;; This short function is a suitable function for byte codes.

;;;###autoload
(fset 'durand-completion-scroll-up-or-go-to-minibuffer
      (make-byte-code
       #x100
       (unibyte-string 137 132 7 0 192 178 1 193 1 91 33 135)
       (vector 1 #'durand-completion-scroll-down-or-go-to-minibuffer)
       5
       "Scroll up; if this is not feasible, go to the mini-buffer.
ARG means do this command ARG times."
       "p"))

;; (defun durand-completion-scroll-up-or-go-to-minibuffer (&optional arg)
;;   "Scroll up; if this is not feasible, go to the mini-buffer.
;; ARG means do this command ARG times."
;;   (interactive "p")
;;   (durand-completion-scroll-down-or-go-to-minibuffer (- arg)))

;;; Use completion to select text that was killed before.

;;;###autoload
(defun yank-complete-rotated-kill-ring ()
  "Return the rotated kill ring so that the current kill is at the top."
  (let* ((tail kill-ring-yank-pointer)
         (len-tail (length tail))
         (len (length kill-ring))
         (copied (copy-tree kill-ring))
         (head (progn (setcdr (nthcdr (mod (- -1 len-tail)
                                           len)
                                      copied)
                              nil)
                      copied))
         ;; Judged from `current-kill', this can be a list for some
         ;; reason.
         (interprogram-paste (and interprogram-paste-function
				  (funcall interprogram-paste-function))))
    (append (cond ((listp interprogram-paste) interprogram-paste)
                  ((stringp interprogram-paste) (list interprogram-paste)))
            tail head)))

;;;###autoload
(defvar yank-complete-history nil
  "The history of `yank-complete'.")

;;;###autoload
(defun yank-complete (&optional arg)
  "Use completion to select text that was killed before.
If ARG is a cons cell, then put the point at the beginning, the
mark at the end for the first yank."
  ;; This is largely copied from `yank'.
  (interactive)
  (let* ((inhibit-read-only t)
         (kills (yank-complete-rotated-kill-ring))
         (choice (completing-read "Yank: " kills nil
                                    t nil 'yank-complete-history)))
    (setq yank-window-start (window-start))
    (setq this-command t)
    (push-mark)
    (insert-for-yank choice)
    (cond ((consp arg)
           (goto-char (prog1 (mark t)
		        (set-marker (mark-marker) (point) (current-buffer)))))))
  (cond ((eq this-command t)
         (setq this-command 'yank))))

;;; Don't ask me if I want to visit the file again.

(require 'register)

;;;###autoload
(cl-defmethod register-val-jump-to ((val cons) delete)
  (cond
   ((frame-configuration-p (car val))
    (set-frame-configuration (car val) (not delete))
    (goto-char (cadr val)))
   ((window-configuration-p (car val))
    (set-window-configuration (car val))
    (goto-char (cadr val)))
   ((eq (car val) 'file)
    (find-file (cdr val)))
   ((eq (car val) 'file-query)
    (find-buffer-visiting (nth 1 val))
    (find-file (nth 1 val))
    (goto-char (nth 2 val)))
   (t (cl-call-next-method val delete))))

;;; Intentionally disable some key-bindings.

;; Using byte-code is fun.

;;;###autoload
(fset 'intentionally-disabled-bind
      (make-byte-code
       0 (unibyte-string 194 195 193 192 32 33 34 135)
       (vector 'this-command-keys-vector 'key-description 'user-error
               "You pressend an intentionally disabled key-binding: %s")
       4 "Warn the user that this key-binding is intentionally disabled."
       nil))

;; (defun intentionally-disabled-bind (arg)
;;   "Warn the user that this key-binding is intentionally disabled."
;;   (interactive)
;;   (user-error "You pressed an intentionally disabled key-binding: %s, %s"
;;               (key-description (this-command-keys-vector))
;;               arg))

;;; Hide some minor mode from the mode line display.

;;;###autoload
(defmacro durand-hide-minor-mode (minor &optional to-require light)
  "Hide MINOR from the mode line.
Require TO-REQUIRE so that we don't have errors.

Optional LIGHT means to use the lighter name instead of
completely hiding it."
  ;; (cond (to-require (require to-require)))
  (cond
   (to-require `(eval-after-load ',to-require
                 (quote
                  (setcdr
                   (assq ',minor minor-mode-alist)
                   (list (or ,light ""))))))
   (`(setcdr (assq ',minor minor-mode-alist) (list (or ,light ""))))))

(provide 'common)
;;; common.el ends here.



;;; Archives

;; ;;;###autoload
;; (defvar yank-pop-completion-index 0
;;   "The index of the current kill.")

;; ;;;###autoload
;; (defun yank-pop-cycle-candidate (&optional arg)
;;   "Cycle the candidates by the offset ARG.
;; This is intended to be bound in the minibuffer-local-completion-map."
;;   (interactive "p")
;;   (cond ((minibufferp))
;;         ((listp minibuffer-completion-table))
;;         ((error "Function `yank-pop-cycle-candidate' called in a weird place")))
;;   (delete-minibuffer-contents)
;;   (let ((len (length minibuffer-completion-table)))
;;     (setq yank-pop-completion-index (+ arg yank-pop-completion-index))
;;     (insert (nth (mod yank-pop-completion-index len)
;;                  minibuffer-completion-table))))

;; ;;;###autoload
;; (defun yank-pop-completion-previous-candidate (&optional arg)
;;   "Go to the previous ARG candidate.
;; This is intended to be bound in the minibuffer-local-completion-map."
;;   (interactive "p")
;;   (yank-pop-cycle-candidate (- arg)))

;; ;;;###autoload
;; (defun yank-pop-completion-set-minibuffer ()
;;   "Set up minibuffer for use of `yank-pop-complete'."
;;   (setq yank-pop-completion-index 0)
;;   (define-key minibuffer-local-completion-map
;;     (vector ?\M-p) #'yank-pop-completion-previous-candidate)
;;   (define-key minibuffer-local-completion-map
;;     (vector ?\M-n) #'yank-pop-cycle-candidate)
;;   (add-hook 'minibuffer-exit-hook #'yank-pop-completion-clear))

;; ;;;###autoload
;; (defun yank-pop-completion-clear ()
;;   "Clear the traces of `yank-pop-complete'."
;;   (setq yank-pop-completion-index 0)
;;   (define-key minibuffer-local-completion-map
;;     (vector ?\M-p) #'previous-history-element)
;;   (define-key minibuffer-local-completion-map
;;     (vector ?\M-n) #'next-history-element)
;;   (remove-hook 'minibuffer-exit-hook #'yank-pop-completion-clear))