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

(defun pip-frame-delete-frame ()
  ""
  (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 ()
  (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 (current-buffer))))

;;;###autoload
(defun pip-frame-add-buffer ()
  ""
  (interactive)
  (let ((frame (or (pip-frame--get-frame t))))
    (if frame
        (pip-frame--add-additional-buffer)
      (pip-frame--make-frame))))

(defun pip-frame-remove-buffer (buffer-name)
  ""
  (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 ()
  ""
  (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)