pip-frame/pip-frame.el

182 lines
6.7 KiB
EmacsLisp
Raw Normal View History

2022-05-06 23:13:52 +02:00
;;; pip-frame.el --- PIP frame support -*- lexical-binding: t -*-
;; Copyright (C) 2022 Milan Zamazal <pdm@zamazal.org>
;; COPYRIGHT NOTICE
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;; Display a floating Emacs frame with selected buffers.
;; Similar to PIP on screens. Probably most useful in EXWM.
;;
;; Use `M-x pip-frame-add-buffer' to create the frame and add
;; additional buffers to it and remove the buffers with
;; `M-x pip-frame-remove-buffer' or close the whole frame with
;; `M-x pip-frame-delete-frame'.
(require 'cl-lib)
(defgroup pip-frame ()
"Display PIP frame.")
(defcustom pip-frame-scale 4
"How many times to shrink the PIP frame relative to the display size."
:type 'number
:group 'pip-frame)
(defcustom pip-frame-font-scale 2
"How many times to reduce the font size in the PIP frame."
:type 'number
:group 'pip-frame)
(defcustom pip-frame-move-step 0.1
"Movement step relative to the display size in the given direction.
Usually, the value should be larger than 0 and much smaller than 1."
:type 'number
:group 'pip-frame)
(defcustom pip-frame-parameters
'((left . 0.9)
(top . 0.9))
"Alist of frame parameters to use for the PIP frame.
The frame size is determined automatically using `pip-frame-scale'
custom option but it can be overriden here."
:type '(alist :key-type symbol :value-type sexp)
:group 'pip-frame)
(defcustom pip-frame-face-attributes '()
"Alist of face attributes to modify `default' face in the PIP frame."
:type '(alist :key-type symbol :value-type sexp)
:group 'pip-frame)
(defvar pip-frame--name "PIP-frame")
(defun pip-frame--get-frame (&optional no-error)
(let ((frame (cl-find pip-frame--name (frame-list)
:key #'(lambda (f) (frame-parameter f 'name)))))
(or frame
(unless no-error
(error "No PIP frame")))))
(defun pip-frame--make-frame (buffer)
2022-05-06 23:13:52 +02:00
(let ((frame (make-frame `((name . ,pip-frame--name)
(unsplittable . t)
,@pip-frame-parameters
(width . ,(/ 1.0 pip-frame-scale))
(height . ,(/ 1.0 pip-frame-scale)))))
(frame-inhibit-implied-resize t)
(face-height (round (/ (face-attribute 'default :height) pip-frame-font-scale))))
(set-face-attribute 'default frame :height face-height)
(mapc #'(lambda (p) (set-face-attribute 'default frame (car p) (cdr p)))
pip-frame-face-attributes)
(set-window-buffer (car (window-list frame)) buffer)
2022-05-06 23:13:52 +02:00
frame))
(defun pip-frame-delete-frame ()
2022-05-16 07:10:16 +02:00
"Delete the PIP frame."
2022-05-06 23:13:52 +02:00
(interactive)
(delete-frame (pip-frame--get-frame)))
(defun pip-frame--buffers ()
(mapcar #'window-buffer (window-list (pip-frame--get-frame))))
(defun pip-frame--add-additional-buffer (buffer)
2022-05-06 23:13:52 +02:00
(let* ((windows (window-list (pip-frame--get-frame)))
(sizes (mapcar #'(lambda (w)
(let ((width (window-body-width w t))
(height (window-body-height w t)))
(cons (+ (* width width) (* height height))
w)))
windows))
(largest (cdr (cl-first (cl-sort sizes #'> :key #'car))))
(side (if (> (window-body-width largest t) (* 2 (window-body-height largest t)))
'right
'below))
(new-window (split-window largest nil side)))
(set-window-buffer new-window buffer)))
2022-05-06 23:13:52 +02:00
;;;###autoload
(defun pip-frame-add-buffer (&optional buffer-or-name)
"Add a buffer to the PIP frame.
2022-05-16 07:10:16 +02:00
If there is no PIP frame then create one.
If BUFFER-OR-NAME is specified, add the given buffer to the frame,
otherwise add the current buffer.
2022-05-16 07:10:16 +02:00
A buffer can be added and displayed multiple times in the frame."
2022-05-06 23:13:52 +02:00
(interactive)
(let ((frame (pip-frame--get-frame t))
(buffer (get-buffer (or buffer-or-name (current-buffer)))))
2022-05-06 23:13:52 +02:00
(if frame
(pip-frame--add-additional-buffer buffer)
(pip-frame--make-frame buffer))))
2022-05-06 23:13:52 +02:00
(defun pip-frame-remove-buffer (buffer-name)
2022-05-16 07:10:16 +02:00
"Remove buffer named BUFFER-NAME from the PIP frame.
If it is the last buffer in the PIP frame, delete the frame."
2022-05-06 23:13:52 +02:00
(interactive (list (completing-read "Remove PIP buffer: "
(mapcar #'buffer-name (pip-frame--buffers))
nil t)))
(let* ((windows (window-list (pip-frame--get-frame)))
(windows-to-delete (cl-remove buffer-name windows
:key #'(lambda (w) (buffer-name (window-buffer w)))
:test-not #'string=)))
(if (= (length windows-to-delete) (length windows))
(pip-frame-delete-frame)
(mapc #'delete-window windows-to-delete))))
(defun pip-frame--move (x y)
(let ((frame (pip-frame--get-frame)))
(set-frame-parameter frame 'left (+ (frame-parameter frame 'left) x))
(set-frame-parameter frame 'top (+ (frame-parameter frame 'top) y))))
(defun pip-frame--move-step (vertical)
(if (integerp pip-frame-move-step)
pip-frame-move-step
(let ((workarea (cdr (assoc 'workarea (cl-first (display-monitor-attributes-list))))))
(round (* pip-frame-move-step (nth (if vertical 3 2) workarea))))))
(defun pip-frame-move-left ()
(interactive)
(pip-frame--move (- (pip-frame--move-step nil)) 0))
(defun pip-frame-move-right ()
(interactive)
(pip-frame--move (pip-frame--move-step nil) 0))
(defun pip-frame-move-up ()
(interactive)
(pip-frame--move 0 (- (pip-frame--move-step t))))
(defun pip-frame-move-down ()
(interactive)
(pip-frame--move 0 (pip-frame--move-step t)))
(defvar pip-frame-move-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") 'pip-frame-move-left)
(define-key map (kbd "<right>") 'pip-frame-move-right)
(define-key map (kbd "<up>") 'pip-frame-move-up)
(define-key map (kbd "<down>") 'pip-frame-move-down)
map))
(defun pip-frame-move ()
2022-05-16 07:10:16 +02:00
"Move PIP frame interactively.
Use arrow keys to move the frame around.
Any other key stops this command and executes its own command."
2022-05-06 23:13:52 +02:00
(interactive)
(message "Use arrow keys to move the frame, any other key to quit")
(set-transient-map pip-frame-move-map t))
(provide 'pip-frame)