boxes/boxes.lisp

;;;; boxes.lisp

(in-package #:boxes)


(defvar *views* '())

(defvar *displayingp* nil)

(defclass primitive-box ()
  ((visiblep :reader visiblep :initform nil)
   (view :reader view :initform nil)
   (keymap :reader keymap :initform (keymap:make-keymap))
   (secondary-keymaps :accessor secondary-keymaps :initform '())))

(defun (setf view) (view box)
  (check-type view primitive-box)
  (setf (slot-value box 'view) view)
  (dolist (c (children box))
    (when c
      (setf (view c) view)))
  view)

(defmethod (setf visiblep) (value (box primitive-box))
  (dolist (c (children box))
    (when c
      (setf (visiblep c) value)))
  (setf (slot-value box 'visiblep) value))

(defclass window-box (primitive-box)
  ((window :accessor window :initarg :window :initform nil)
   (stumpwm-frame :reader stumpwm-frame :initform (stumpwm::make-frame :number 0
                                                                       :x 0
                                                                       :y 0
                                                                       :width *screen-width*
                                                                       :height *screen-height*
                                                                       :window nil))))

(defun frame-window-sync (frame window)
  (setf (stumpwm::frame-window frame) window)
  (when window
    (setf (stumpwm::window-frame window) frame)))

(defmethod initialize-instance :after ((box window-box) &rest initargs)
  (declare (ignore initargs))
  (frame-window-sync (stumpwm-frame box) (window box)))

(defmethod (setf window) :after ((window stumpwm:window) (box window-box))
  (frame-window-sync (stumpwm-frame box) (window box)))

(defgeneric set-screen-position (box x y width height))

(defmethod set-screen-position ((box window-box) x y width height)
  (check-type x integer)
  (check-type y integer)
  (check-type width integer)
  (check-type height integer)
  ;; todo compare with the screen dimensions
  (let ((frame (stumpwm-frame box)))
    (setf (stumpwm:frame-x frame) x
          (stumpwm:frame-y frame) y
          (stumpwm:frame-width frame) width
          (stumpwm:frame-height frame) height)))

(defclass double-box (primitive-box)
  ((split-ratio :accessor split-ratio :initarg :split-ratio :initform 1/2)
   (split-direction :reader split-direction :initarg :split-direction :initform (error "Missing split direction!"))
   (1st :accessor 1st :initarg :1st)
   (2nd :accessor 2nd :initarg :2nd)
   (current-child :accessor current-child :initform nil)))

(defmethod set-screen-position ((box double-box) x y width height)
  (flet ((new-params (coord dimension)
           (let* ((new-dimension-0 (truncate (* (split-ratio box)
                                                dimension)))
                  (new-dimension-1 (- dimension new-dimension-0))
                  (new-coord-1 (+ coord new-dimension-0)))
             (values new-dimension-0 new-dimension-1 new-coord-1))))
    (if (eql (split-direction box) :column)
        (multiple-value-bind (new-dimension-0 new-dimension-1 new-coord-1) (new-params y height)
          (set-screen-position (1st box) x y width new-dimension-0)
          (set-screen-position (2nd box) x new-coord-1 width new-dimension-1))
        (multiple-value-bind (new-dimension-0 new-dimension-1 new-coord-1) (new-params x width)
          (set-screen-position (1st box) x y new-dimension-0 height)
          (set-screen-position (2nd box) new-coord-1 y new-dimension-1 height)))))

(defgeneric children (box))

(defmethod children ((box primitive-box))
  '())

(defmethod children ((box double-box))
  (list (1st box) (2nd box)))

(defmethod (setf 1st) :before (child (box double-box))
  (check-type child primitive-box)
  (when (visiblep box)
    (setf (visiblep (1st box)) nil)))

(defmethod (setf 1st) :after (child (box double-box))
  (check-type child primitive-box)
  (when (visiblep box)
    (display (view box))))

(defmethod (setf 2nd) :before (child (box double-box))
  (check-type child primitive-box)
  (when (visiblep box)
    (setf (visiblep (2nd box)) nil)))

(defmethod (setf 2nd) :after (child (box double-box))
  (check-type child primitive-box)
  (when (visiblep box)
    (display (view box))))

(defun descendants (box)
  (let ((children (children box)))
    (cons box
          (loop for c in children
                append (descendants c)))))

(defparameter *screen-width* (stumpwm:screen-width (stumpwm:current-screen)))
(defparameter *screen-height* (stumpwm:screen-height (stumpwm:current-screen)))

(defun display (box &optional (previous-box nil previous-box-supplied-p))
  (if (typep box 'dialog-box)
      (progn
        (if previous-box-supplied-p
            (display (dialog-parent-box box) previous-box)
            (display (dialog-parent-box box)))
        (stumpwm:focus-window (window box)))
      (unless *displayingp*
        (let ((*displayingp* t))
          (when previous-box-supplied-p
            (setf (visiblep previous-box) nil))
          (setf (visiblep box) t)
          (setf (view box) box)
          (set-screen-position box 0 0 *screen-width* *screen-height*)
          (let ((frames (loop for d in (descendants box)
                              when (typep d 'window-box)
                              collect (stumpwm-frame d))))
            (draw-frames frames (stumpwm:current-group)))
          (values box previous-box)))))

#|
(defgeneric current (box))

(defmethod current ((box box))
  box)

(defmethod current ((box double-box))
  (current-child box))

(defgeneric ensure-current (box))

(defmethod ensure-current ((box box))
  box)

(defmethod ensure-current ((box double-box))
  (unless (member (current-child box)
                  (list (1st box) (2nd box)))
    (ensure-current (1st box))))
(defgeneric minimal-current (box))

(defmethod minimal-current ((box box))
  (current box))

(defmethod minimal-current ((box double-box))
  (minimal-current (current box)))
|#

(defgeneric box-to-frame (box x y width height))

(defclass box (primitive-box)
  ((contents :reader contents :initarg :contents :initform (make-instance 'primitive-box))))

(defmethod (setf contents) (contents (box box))
  (check-type contents primitive-box)
  (when (and (visiblep box) (contents box))
    (setf (visiblep (contents box)) nil))
  (setf (slot-value box 'contents) contents)
  (when (visiblep box)
    (display (view box))))

(defmethod set-screen-position ((box box) x y width height)
  (set-screen-position (contents box) x y width height))

(defmethod children ((box box))
  (list (contents box)))

(defun nonempty-list-of-frames-p (thing)
  (and thing
       (listp thing)
       (every #'stumpwm::frame-p thing)))

(in-package #:stumpwm)


(defun boxes::draw-frames (frames group)
  (check-type frames (satisfies boxes::nonempty-list-of-frames-p))
  (check-type group tile-group)
  (let ((windows (group-windows group)))
    (labels ((give-frame-a-window (f)
               (unless (frame-window f)
                 (setf (frame-window f) (find f windows :key 'window-frame)))))
      (loop for i from 0
            for frame in frames
            do (setf (frame-number frame) i))
      (setf (tile-group-frame-tree group) (list frames))
      (setf (tile-group-current-frame group) (find 0 (group-frames group) :key 'frame-number) )
      ;; give any windows still not in a frame a frame
      ;; otherwise BOOOOOOM!
      (dolist (w windows)
        (unless (window-frame w)
          (setf (window-frame w) (tile-group-current-frame group))))
      ;; FIXME: if the current window was blank in the dump, this does not honour that.
      (give-frame-a-window (tile-group-current-frame group))
      ;; raise the curtains
      (let ((visible-windows (loop for frame in (group-frames group)
                                   when (frame-window frame)
                                   collect it)))

        (dolist (w visible-windows)
          (unhide-window w))
        (dolist (w (set-difference windows visible-windows))
          (hide-window w))
        )
      (sync-all-frame-windows group)
      (focus-frame group (tile-group-current-frame group)))))

(in-package #:boxes)

(defstruct (names (:conc-name nil))
  (names-to-objects (make-hash-table :test 'equalp))
  (objects-to-names (make-hash-table :test 'eq)))

(defvar *names*)

(defun by-name (object &optional (names *names*))
  (gethash object (names-to-objects names)))

(defun name (name &optional (names *names*))
  (gethash name (objects-to-names names)))

(defun (setf name) (name object &optional (names *names*))
  (remhash (name object names) (names-to-objects names))
  (if (null name)
      (remhash object (objects-to-names names))
      (setf (gethash name (names-to-objects names)) object
        (gethash object (objects-to-names names)) name))
  name)

(defvar *view-names* (make-names))

(defgeneric view-name (view))

(defmethod view-name (view)
  (name view *view-names*))

(defgeneric (setf view-name) (name view))

(defmethod (setf view-name) (name view)
  (setf (name view *view-names*) name))

(defun view-by-name (name)
  (by-name name *view-names*))

(defvar *view* (make-instance 'box))

(defun current-view ()
  *view*)

(defun (setf current-view) (box)
  (check-type box primitive-box)
  (display box *view*) 
  (setf *view* box)
  (setf *views* (cons box (delete box *views*)))
  (keymap:install (apply #'keymap:make-keymap
			 (keymap box)
                         (append (secondary-keymaps box)
                                 (list *global-shortcuts*))))
  box)

(defclass dialog-box (window-box)
  ((parent :reader dialog-parent-box :initarg :parent :initform (error "Vbi sunt parentes mei?"))))

(defun register-window-box (window)
  (let ((box (if (eql (stumpwm:window-type window) :dialog)
                 (make-instance 'dialog-box :window window :parent *view*)
                 (make-instance 'window-box :window window))))
    (setf (current-view) box)))

(defun update-window-boxes (&rest args)
  (declare (ignore args))
  (let (parent)
    (setf *views* (remove-if (lambda (view)
                               (if (and (typep view 'window-box)
                                        (window view)
                                        (zerop (stumpwm:window-state (window view))))
                                   (progn
                                     (when (typep view 'dialog-box)
                                       (setf parent (dialog-parent-box view)))
                                     t)
                                   nil))
                             *views*))
    (unless (member *view* *views*)
      (setf (current-view) (or parent (first *views*))))))

(stumpwm:add-hook stumpwm:*new-window-hook* 'register-window-box)
(stumpwm:add-hook stumpwm:*destroy-window-hook* 'update-window-boxes)

(defun select-view-from-menu (&optional (initial-selection 0))
  (second (stumpwm:select-from-menu (stumpwm:current-screen)
                                    (loop for view in *views*
                                          collect (list (or (view-name view)
                                                            (and (typep view 'window-box)
                                                                 (stumpwm:window-title (window view)))
                                                            (write-to-string view)) view))
                                    "  Views:" 
                                    initial-selection)))

(defun rresize (q)
  "rresize"
  (setf (split-ratio *view*) (* q (split-ratio *view*)))
  (setf (current-view) *view*))

#+nil (defmethod view-name ((box box-with-window))
  (let* ((title (stumpwm:window-title (window box)))
         (length (length title)))
    (if (< length 13)
        title
        (format nil "~A..~A" (subseq title 0 5) (subseq title (- length 5))))))

(defgeneric delete-view (view))

(defmethod delete-view (view)
  (setf *views* (delete view *views*))
  (when (eql view *view*)
    (setf (current-view) (first *views*))))

(defmethod delete-view ((view window-box))
  (stumpwm:delete-window (window view))
  (call-next-method))

;; TODO lock

(defmacro defkey ((key &optional (keymap (keymap *view*))) &body body)
  `(keymap:add-binding ,key (lambda () ,@body) ,keymap))

(defvar *global-shortcuts* (keymap:make-keymap))

(defun add-global-shortcut (key thunk)
  (keymap:add-binding key thunk *global-shortcuts*))

(defmacro define-global-shortcut (key &body body)
  `(add-global-shortcut ,key (lambda () ,@body)))

(define-global-shortcut "M-s-Left" (rresize 0.99))
(define-global-shortcut "M-s-Right" (rresize 1.01))

(define-global-shortcut "M-Tab" (setf (current-view) (second *views*)))

(define-global-shortcut "F4" (delete-view *view*))

(defun window-pid (w)
  (first (stumpwm::window-property w :_NET_WM_PID)))

(defun launch-catch-window (command &optional (timeout 10))
  (let ((process (uiop:launch-program command :force-shell nil)))
    (let ((pid (uiop:process-info-pid process)))
      (loop repeat (floor (* timeout 20))
            for windows = (stumpwm:group-windows (stumpwm:current-group))
            for my-window = (find pid windows :key #'window-pid)
            do (sleep 0.1)
            when my-window do (return (values process my-window))
            finally (return (values process nil))))))

(defun resolve-view-designator (designator)
  (etypecase designator
    (primitive-box designator)
    (string (or (view-by-name designator) (make-instance 'window-box)))
    (null (make-instance 'window-box))))

(defun hb (&optional (left *view*) (right (second *views*)) (ratio 1/2))
  (make-instance 'double-box
                 :split-direction :row
                 :split-ratio ratio
                 :1st (resolve-view-designator left)
                 :2nd (resolve-view-designator right)))

(defun hb! (&optional (left *view*) (right (second *views*)) (ratio 1/2))
  (setf (current-view) (hb left right ratio)))

(defun vb (&optional (top *view*) (bottom (second *views*)) (ratio 1/2))
  (make-instance 'double-box
                 :split-direction :column
                 :split-ratio ratio
                 :1st (resolve-view-designator top)
                 :2nd (resolve-view-designator bottom)))

(defun vb! (&optional (top *view*) (bottom (second *views*)) (ratio 1/2))
  (setf (current-view) (vb top bottom ratio)))

(defun vm (&optional (initial-selection 0))
  (select-view-from-menu initial-selection))

(defun n! (name &optional (view *view*))
  (setf (view-name view) name))

(define-symbol-macro %
  *view*)

(define-symbol-macro %%
  (second *views*))

(define-symbol-macro %%%
  (third *views*))

(define-symbol-macro _
  (vm))

(define-symbol-macro {
  (1st *view*))

(define-symbol-macro }
  (2nd *view*))

(defun {! (view)
  (setf (1st *view*) (resolve-view-designator view)))

(defun }! (view)
  (setf (2nd *view*) (resolve-view-designator view)))

(define-global-shortcut "F12" (let ((view (select-view-from-menu 1)))
				(when view
				  (setf (current-view) view))))