Butchered wm.el

wm.el

;;
(require 'cl)

(defstruct wm-window buffer point start hscroll dedicated persistent-parameters)

(defvar wm-workspaces nil)
(defvar wm-layouts '(wm-layout-stacked-columns
		     wm-layout-stacked-rows
		     wm-layout-grid
		     wm-layout-bisection
		     wm-layout-fullscreen
		     wm-layout-col-col-stack))

(defmacro wm-when-let (binding &rest body)
  (declare (indent 1))
  `(let ((,(first binding) ,(second binding)))
     (when ,(first binding)
       ,@body)))

(defun wm--initialise-frame-parameters ()
  ;; TODO: Use `modify-all-frames-parameters' instead?
  (setf (frame-parameter nil 'wm-workspace) 0)
  (setf (frame-parameter nil 'wm-layout) 0))

(defun wm--snapshot-windows ()
  (setf (frame-parameter nil 'wm-focus) (position (selected-window) (wm-emacs-windows)))
  (setf (frame-parameter nil 'wm-windows) (mapcar 'wm-window-from-emacs-window (wm-emacs-windows)))
  (setf (frame-parameter nil 'wm-windows-alist) nil))

(defun wm--persistent-parameters-from-emacs-window (window)
  (let (pps)
    (mapc
     (lambda (kv)
       (when (cdr kv)
	 (let* ((pp-key (car kv))
		(pp-value (window-parameter window pp-key)))
	   (setf pps
		 (cons (cons pp-key pp-value)
		       pps)))))
     window-persistent-parameters)
    pps))

(defun wm--set-persistent-parameters (window pps)
  (mapc
   (lambda (kv)
     (set-window-parameter window (car kv) (cdr kv)))
   pps))

(defun wm-window-from-emacs-window (window)
  (make-wm-window :buffer (window-buffer window)
		  :point (window-point window)
		  :start (window-start window)
		  :hscroll (window-hscroll window)
		  :dedicated (window-dedicated-p window)
		  :persistent-parameters (wm--persistent-parameters-from-emacs-window window)))

(defun wm-window-from-buffer (buffer)
  (make-wm-window :buffer buffer :point 0 :start 0 :hscroll 0))

(defun wm-restore-window (window)
  (set-window-buffer nil (wm-window-buffer window))
  (set-window-point nil (wm-window-point window))
  (set-window-start nil (wm-window-start window) t)
  (set-window-hscroll nil (wm-window-hscroll window))
  (set-window-dedicated-p nil (wm-window-dedicated window))
  (wm--set-persistent-parameters (selected-window) (wm-window-persistent-parameters window)))

(defun wm-emacs-windows ()
  (window-list nil nil (frame-first-window)))

(defun wm-update-windows ()
  (unless (assoc 'wm-windows (frame-parameters nil))
    (wm--initialise-frame-parameters)
    (wm--snapshot-windows)		;...and take a snapshot to get
					;things started.
    )		
  (dolist (window (wm-emacs-windows))
    (wm-when-let (kv (assoc window (frame-parameter nil 'wm-windows-alist)))
      (setf (nth (cdr kv) (frame-parameter nil 'wm-windows)) (wm-window-from-emacs-window window)))))

(defun wm-update-focus ()
  (wm-when-let (kv (assoc (selected-window) (frame-parameter nil 'wm-windows-alist)))
    (setf (frame-parameter nil 'wm-focus) (cdr kv))))

(defun wm-status ()
  (let ((status ""))
    (dotimes (n (length (frame-parameter nil 'wm-windows)))
      (let ((focused (= n (frame-parameter nil 'wm-focus)))
	    (window (nth n (frame-parameter nil 'wm-windows))))
	(setf status (format "%s%-20s"
			     status
			     (concat (if focused "[" " ")
				     (format "%d: %s" (1+ n) (buffer-name (wm-window-buffer window)))
				     (if focused "] " "  "))))))
    (format "%-35s %s" (format "<%d> %s: " (1+ (frame-parameter nil 'wm-workspace)) (symbol-name (nth (frame-parameter nil 'wm-layout) wm-layouts)))  status)))

(defun wm-display-status ()
  (let ((message-log-max nil)
	(message-truncate-lines t))
    (message (wm-status))))

(defun wm-reset-layout ()
  (delete-other-windows)
  (split-window)
  (other-window 1)
  (delete-other-windows))

(defun wm-layout-fullscreen ()
  (wm-reset-layout)
  (wm-restore-window (nth (frame-parameter nil 'wm-focus) (frame-parameter nil 'wm-windows)))
  (setf (frame-parameter nil 'wm-windows-alist) (list (cons (selected-window) (frame-parameter nil 'wm-focus)))))

(defun wm-layout-grid ()
  (wm-reset-layout)
  (let* ((n 0)
	 (len (length (frame-parameter nil 'wm-windows)))
	 (sqrt-len (truncate (sqrt len)))
	 (dim (if (= len (* sqrt-len sqrt-len)) sqrt-len (1+ sqrt-len))))
    (dotimes (y (1- (/ (+ len (1- dim)) dim)))
      (split-window-vertically))
    (while (< n len)
      (dotimes (x dim)
	(when (< n len)
	  (wm-restore-window (nth n (frame-parameter nil 'wm-windows)))
	  (incf n))
	(when (and (< x (1- dim)) (< n len))
	  (split-window-horizontally)
	  (other-window 1)))
      (other-window 1)))
  (balance-windows)
  (other-window (frame-parameter nil 'wm-focus))
  (let ((n -1))
    (setf (frame-parameter nil 'wm-windows-alist) (mapcar (lambda (window) (cons window (incf n)))
							  (wm-emacs-windows)))))

(defun wm-layout-bisection ()
  (wm-reset-layout)
  (dotimes (n (length (frame-parameter nil 'wm-windows)))
    (wm-restore-window (nth n (frame-parameter nil 'wm-windows)))
    (when (< n (1- (length (frame-parameter nil 'wm-windows))))
      (funcall (nth (mod n 2) '(split-window-horizontally split-window-vertically)))
      (other-window 1)))
  (other-window (1+ (frame-parameter nil 'wm-focus)))
  (balance-windows)
  (let ((n -1))
    (setf (frame-parameter nil 'wm-windows-alist) (mapcar (lambda (window) (cons window (incf n)))
							  (wm-emacs-windows)))))

(defun wm-layout-stacked-columns ()
  (wm-reset-layout)
  (wm-restore-window (first (frame-parameter nil 'wm-windows)))
  (when (rest (frame-parameter nil 'wm-windows))
    (split-window-horizontally)
    (other-window 1)
    (loop for (window . more-windows) on (rest (frame-parameter nil 'wm-windows))
	  do (progn
	       (wm-restore-window window)
	       (when more-windows
		 (split-window-vertically)
		 (other-window 1))))
    (balance-windows)
    (other-window (1+ (frame-parameter nil 'wm-focus))))
  (let ((n -1))
    (setf (frame-parameter nil 'wm-windows-alist) (mapcar (lambda (window) (cons window (incf n)))
							  (wm-emacs-windows)))))

(defun wm-layout-stacked-rows ()
  (wm-reset-layout)
  (wm-restore-window (first (frame-parameter nil 'wm-windows)))
  (when (rest (frame-parameter nil 'wm-windows))
    (split-window-vertically)
    (other-window 1)
    (loop for (window . more-windows) on (rest (frame-parameter nil 'wm-windows))
	  do (progn
	       (wm-restore-window window)
	       (when more-windows
		 (split-window-horizontally)
		 (other-window 1))))
    (balance-windows)
    (other-window (1+ (frame-parameter nil 'wm-focus))))
  (let ((n -1))
    (setf (frame-parameter nil 'wm-windows-alist) (mapcar (lambda (window) (cons window (incf n)))
							  (wm-emacs-windows)))))

(defun wm-layout-col-col-stack ()
  (wm-reset-layout)
  (cl-loop for w being the elements of (frame-parameter nil 'wm-windows) using (index i) do
	   (cond
	    ((= i 0)
	     )
	    ((= i 1)
	     (split-window-horizontally)
	     (other-window 1))
	    ((= i 2)
	     (split-window-horizontally)
	     (other-window 1))
	    (t
	     (split-window-vertically)
	     (other-window 1)))
	   
	   (balance-windows)

	   (wm-restore-window w))
  (other-window (1+ (frame-parameter nil 'wm-focus)))
  (let ((n -1))
    (setf (frame-parameter nil 'wm-windows-alist) (mapcar (lambda (window) (cons window (incf n)))
							  (wm-emacs-windows))))
  )

(defun wm-update-layout ()
  (wm-update-windows)
  (funcall (nth (frame-parameter nil 'wm-layout) wm-layouts))
  (wm-display-status))

(defun wm-cycle-layout ()
  (interactive)
  (when (= (incf (frame-parameter nil 'wm-layout)) (length wm-layouts))
    (setf (frame-parameter nil 'wm-layout) 0))
  (wm-update-focus)
  (wm-update-windows)
  (wm-update-layout))

(defun wm-focus-next-window ()
  (interactive)
  (wm-update-windows)
  (wm-update-focus)
  (when (= (incf (frame-parameter nil 'wm-focus)) (length (frame-parameter nil 'wm-windows)))
    (setf (frame-parameter nil 'wm-focus) 0))
  (wm-update-layout))

(defun wm-focus-previous-window ()
  (interactive)
  (wm-update-windows)
  (wm-update-focus)
  (when (= (decf (frame-parameter nil 'wm-focus)) -1)
    (setf (frame-parameter nil 'wm-focus) (1- (length (frame-parameter nil 'wm-windows)))))
  (wm-update-layout))

(defun wm-remove-nth (n lst)
  (when lst
    (if (zerop n)
	(rest lst)
      (cons (first lst) (wm-remove-nth (1- n) (rest lst))))))

(defun wm-delete (n)
  (when (and (> (length (frame-parameter nil 'wm-windows)) 1) (< n (length (frame-parameter nil 'wm-windows))))
    (setf (frame-parameter nil 'wm-windows) (wm-remove-nth n (frame-parameter nil 'wm-windows)))
    (setf (frame-parameter nil 'wm-windows-alist) (remove-if (lambda (kv) (= (cdr kv) n)) (frame-parameter nil 'wm-windows-alist)))
    (dolist (kv (frame-parameter nil 'wm-windows-alist))
      (when (> (cdr kv) n)
	(decf (cdr kv))))
    (when (= (frame-parameter nil 'wm-focus) (length (frame-parameter nil 'wm-windows)))
      (setf (frame-parameter nil 'wm-focus) 0))
    (wm-update-layout)))

(defun wm-push-window ()
  (interactive)
  (wm-update-windows)
  (setf (frame-parameter nil 'wm-windows) (append (frame-parameter nil 'wm-windows) (list (wm-window-from-emacs-window (selected-window)))))
  (wm-update-layout))

(defun wm-pop-window ()
  (interactive)
  (wm-delete (1- (length (frame-parameter nil 'wm-windows)))))

(defun wm-kill-focused-window ()
  (interactive)
  (wm-update-focus)
  (wm-delete (frame-parameter nil 'wm-focus)))

(defun wm-set-focused-window (n)
  (interactive "p")
  (when (< n (length (frame-parameter nil 'wm-windows)))
    (setf (frame-parameter nil 'wm-focus) n)
    (wm-update-layout)))

(defun wm-snapshot-windows ()
  (interactive)
  (wm--snapshot-windows)
  (wm-update-layout))

(defun wm-restore-workspace (layout focus windows)
  (setf (frame-parameter nil 'wm-layout) layout)
  (setf (frame-parameter nil 'wm-focus) focus)
  (setf (frame-parameter nil 'wm-windows) windows)
  (setf (frame-parameter nil 'wm-windows-alist) nil)
  (wm-update-layout))

(defun wm-save-workspace (workspace)
  (wm-update-focus)
  (wm-update-windows)
  (unless (assoc workspace wm-workspaces)
    (push (cons workspace nil) wm-workspaces))
  (setf (cdr (assoc workspace wm-workspaces)) (list (frame-parameter nil 'wm-layout) (frame-parameter nil 'wm-focus) (frame-parameter nil 'wm-windows))))

(defun wm-switch-workspace (workspace)
  (wm-save-workspace (frame-parameter nil 'wm-workspace))
  (unless (assoc workspace wm-workspaces)
    (push (cons workspace (list (frame-parameter nil 'wm-layout) 0 (list (wm-window-from-emacs-window (selected-window))))) wm-workspaces))
  (let ((state (cdr (assoc workspace wm-workspaces))))
    (setf (frame-parameter nil 'wm-workspace) workspace)
    (wm-restore-workspace (first state) (second state) (third state))))

(defun wm--split (xs i)
  (let ((n (- (length xs) i)))
    (cons (butlast xs n)
	  (last xs n))))

(defun wm--remove-by-index (xs i)
  (let ((parts (wm--split xs i)))
    (append (car parts) (cddr parts))))

(defun wm--insert-at-index (xs i e)
  (let ((parts (wm--split xs i)))
    (append (car parts) (cons e (cdr parts)))))

(defun wm--move-window (old-index new-index)
  (wm-update-focus)
  (wm-update-windows)
  
  ;; If the current window isn't in the list, insert it somewhere
  ;; sensible and set `wm-focus' to refer to it. If the user is trying
  ;; to move it, presumably they want it to be a window that wm will
  ;; look after.
  (unless (assoc (selected-window) (frame-parameter nil 'wm-windows-alist))
    (lexical-let ((ws (wm-emacs-windows))
  		  next-index)
      (mapc (lambda (w)
  	      (wm-when-let (kv (assoc w (frame-parameter nil 'wm-windows-alist)))
  		(unless next-index
  		  (setf next-index (cdr kv)))))
  	    ws)
      (when next-index
	(when (eq next-index 0)
	  ;; The selected window was last in the list. (When you split
	  ;; a window, the new window comes after the original in the
	  ;; window list - meaning the window at index 0 will never be
	  ;; found because the selected non-wm window was inserted
	  ;; before it, only because the new window is last.)
	  (setf next-index (- (length (frame-parameter nil 'wm-windows)) 1)))
	(message (format "next-index=%d" next-index))
  	(setf (frame-parameter nil 'wm-windows) (wm--insert-at-index (frame-parameter nil 'wm-windows)
								     next-index
								     (wm-window-from-emacs-window (selected-window))))
	(setf (frame-parameter nil 'wm-focus) next-index)

	;; The layout function will recreate `wm-windows-alist', so no
	;; need to fix it up.
	
	)))

  (when (and (>= new-index 0)
	     (< new-index (length (frame-parameter nil 'wm-windows))))
    (let ((old-window (nth old-index (frame-parameter nil 'wm-windows))))
      (setf (frame-parameter nil 'wm-windows) (wm--remove-by-index (frame-parameter nil 'wm-windows) old-index))
      (setf (frame-parameter nil 'wm-windows) (wm--insert-at-index (frame-parameter nil 'wm-windows) new-index old-window)))
    (setf (frame-parameter nil 'wm-focus) new-index))

  (funcall (nth (frame-parameter nil 'wm-layout) wm-layouts))
  (wm-display-status))

(defun wm-bury-window ()
  (interactive)
  (wm--move-window (frame-parameter nil 'wm-focus) (- (length (frame-parameter nil 'wm-windows)) 1)))

(defun wm-unbury-window ()
  (interactive)
  (wm--move-window (frame-parameter nil 'wm-focus) 0))

(defun wm-promote-window ()
  (interactive)
  (wm--move-window (frame-parameter nil 'wm-focus) (+ (frame-parameter nil 'wm-focus) 1)))

(defun wm-demote-window ()
  (interactive)
  (wm--move-window (frame-parameter nil 'wm-focus) (- (frame-parameter nil 'wm-focus) 1)))

(define-minor-mode wm-mode
  nil
  :init-value t
  :global t
  :keymap (let ((keymap (make-sparse-keymap)))
	    (define-key keymap (kbd "M-RET") 'wm-cycle-layout)
	    (define-key keymap (kbd "C-=") 'wm-push-window)
	    (define-key keymap (kbd "C--") 'wm-pop-window)
	    (define-key keymap (kbd "C-0") 'wm-snapshot-windows)
	    (define-key keymap (kbd "C-w") 'wm-kill-focused-window)
	    (define-key keymap (kbd "C-<tab>") 'wm-focus-next-window)
	    (define-key keymap (kbd "C-S-<tab>") 'wm-focus-previous-window)
	    (define-key keymap (kbd "M-1") (lambda () (interactive) (wm-set-focused-window 0)))
	    (define-key keymap (kbd "M-2") (lambda () (interactive) (wm-set-focused-window 1)))
	    (define-key keymap (kbd "M-3") (lambda () (interactive) (wm-set-focused-window 2)))
	    (define-key keymap (kbd "M-4") (lambda () (interactive) (wm-set-focused-window 3)))
	    (define-key keymap (kbd "M-5") (lambda () (interactive) (wm-set-focused-window 4)))
	    (define-key keymap (kbd "M-6") (lambda () (interactive) (wm-set-focused-window 5)))
	    (define-key keymap (kbd "M-7") (lambda () (interactive) (wm-set-focused-window 6)))
	    (define-key keymap (kbd "M-8") (lambda () (interactive) (wm-set-focused-window 7)))
	    (define-key keymap (kbd "M-9") (lambda () (interactive) (wm-set-focused-window 8)))
	    (define-key keymap (kbd "<f1>") (lambda () (interactive) (wm-switch-workspace 0)))
	    (define-key keymap (kbd "<f2>") (lambda () (interactive) (wm-switch-workspace 1)))
	    (define-key keymap (kbd "<f3>") (lambda () (interactive) (wm-switch-workspace 2)))
	    (define-key keymap (kbd "<f4>") (lambda () (interactive) (wm-switch-workspace 3)))
	    keymap)
  (wm-snapshot-windows))

(provide 'wm)

Changes from the original:

1. Uses frame parameters instead of defvars, so the code is really
   ugly but it works when you have multiple frames.
2. Saves and restores window persistent parameters
   (http://www.gnu.org/software/emacs/manual/html_node/elisp/Window-Parameters.html)
3. Has a new col-col-stack layout - 2 columns and a stack.
4. Interactive window moving. Move the selected window up and down the
   stack (wm-promote-window, wm-demote-window) or put it immediately
   to the top or bottom of the stack (wm-bury-window,
   wm-unbury-window). These will add the selected window to the list
   if it wasn't there already.
5. wm-update-windows will take a snapshot if the window list is empty,
   so generally you can just start using one of the wm functions and
   it will do something sensible.