diff --git a/Makefile.in b/Makefile.in index eab7a9f..6db0e63 100644 --- a/Makefile.in +++ b/Makefile.in @@ -23,8 +23,8 @@ keytrans.lisp kmap.lisp input.lisp core.lisp command.lisp menu.lisp \ screen.lisp group.lisp window.lisp floating-group.lisp \ tile-window.lisp window-placement.lisp message-window.lisp \ selection.lisp user.lisp iresize.lisp bindings.lisp events.lisp \ -help.lisp fdump.lisp mode-line.lisp time.lisp color.lisp module.lisp \ -stumpwm.lisp version.lisp +help.lisp fdump.lisp mode-line.lisp mode-line-cubes.lisp time.lisp \ +color.lisp module.lisp stumpwm.lisp version.lisp all: stumpwm stumpwm.info diff --git a/events.lisp b/events.lisp index 6f36c5b..57c5199 100644 --- a/events.lisp +++ b/events.lisp @@ -589,12 +589,14 @@ the window in it's frame." (define-stump-event-handler :button-press (window code x y child time) ;; Pass click to client (xlib:allow-events *display* :replay-pointer time) - (let (screen ml win) + (let (screen ml win cube) (cond ((and (setf screen (find-screen window)) (not child)) (group-button-press (screen-current-group screen) x y :root)) ((setf ml (find-mode-line-window window)) (run-hook-with-args *mode-line-click-hook* ml code x y)) + ((setf cube (find-cube-window window)) + (cube-clicked cube)) ((setf win (find-window-by-parent window (top-windows))) (group-button-press (window-group win) x y win))))) diff --git a/group.lisp b/group.lisp index 26f1a4b..f66527c 100644 --- a/group.lisp +++ b/group.lisp @@ -444,8 +444,8 @@ to the next group." The windows will be moved to group \"^B^2*~a^n\" ^B^6*Confirm?^n " (group-name dead-group) (group-name to-group)))) (progn - (switch-to-group to-group) (kill-group dead-group to-group) + (switch-to-group to-group) (message "Deleted")) (message "Canceled"))))) diff --git a/mode-line-cubes.lisp b/mode-line-cubes.lisp new file mode 100644 index 0000000..c873dd3 --- /dev/null +++ b/mode-line-cubes.lisp @@ -0,0 +1,200 @@ +;;; Modeline cubes - A group switcher widget for the mode-line + +(in-package :stumpwm) +(export '(create-cube create-cubes destroy-cubes find-cube-window cube-clicked)) + +(defparameter *cubes* '()) + +;; Show Group numbers or Group formatted names? +(defparameter *cube-display-number* nil) + +;; border +(defparameter *cube-border-width* 1) +(defparameter *cube-border-color* "Black") +;; colors +(defparameter *cube-background* "Gray") +(defparameter *cube-background-toggled* "Orange") +(defparameter *cube-foreground* "Black") +(defparameter *cube-foreground-toggled* "Black") + +(defstruct cube + state + number + group + window + gcontext-normal + gcontext-toggled) + +(defun create-cube (ml group &optional (x 0)) + "Create cube numer num at position x on mode-line ml" + (let* ((screen (mode-line-screen ml)) + (font (screen-font screen)) + (parent (mode-line-window ml)) + (win (xlib:create-window + :parent parent + :x x + :y 0 + :width (* (xlib:char-width (screen-font screen) 0) 2) + :height (mode-line-height ml) + :border (alloc-color screen *cube-border-color*) + :border-width *cube-border-width* + :event-mask (xlib:make-event-mask :exposure :button-press))) + (fg (alloc-color screen *cube-foreground*)) + (bg (alloc-color screen *cube-background*)) + (fg-toggled (alloc-color screen *cube-foreground-toggled*)) + (bg-toggled (alloc-color screen *cube-background-toggled*)) + (gcontext-normal (xlib:create-gcontext :drawable win + :font font + :foreground fg + :background bg)) + (gcontext-toggled (xlib:create-gcontext :drawable win + :font font + :foreground fg-toggled + :background bg-toggled)) + (cube (make-cube :state :normal + :number (group-number group) + :group group + :window win + ; :mode-line ml + :gcontext-normal gcontext-normal + :gcontext-toggled gcontext-toggled))) + (setf (xlib:window-plist win) (list 'cube cube)) + cube)) + +(defun toggle-cube (cube) + (cond ((eq (cube-state cube) :normal) + (setf (cube-state cube) :toggled)) + ((eq (cube-state cube) :toggled) + (setf (cube-state cube) :normal)))) + +(defun add-cube-group (ml group) + (setf (mode-line-cubes ml) + (sort (append (mode-line-cubes ml) (list (create-cube ml group))) + #'< :key 'cube-number))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; cube events ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; click +(defun cube-clicked (cube) + (let ((new-group (find (cube-number cube) (screen-groups (current-screen)) :key 'group-number))) + (and new-group (switch-to-group new-group)))) + +;; exposure +(defun draw-cube (cube) + (let* ((win (cube-window cube)) + (gc (or (and (eq (cube-state cube) :toggled) (cube-gcontext-toggled cube)) + (cube-gcontext-normal cube))) + (font (xlib:gcontext-font gc)) + ;(xlib:char-width font 0)) + (string (cube-string cube)) + (char-width (xlib:char-width font 0)) + (text-width (xlib:text-width font string)) + (window-width (+ text-width + char-width))) + ;; change window width if different + (unless (eq (xlib:drawable-width win) window-width) + (setf (xlib:drawable-width win) window-width)) + ;; sync window background with gc background + (setf (xlib:window-background win) (xlib:gcontext-background gc)) + (xlib:map-window win) + ;; draw text + (xlib:clear-area win) + (xlib:draw-image-glyphs win gc (round (/ char-width 2)) ;; char-width / 2 draws at center + (xlib:font-ascent font) + string + :translate #'translate-id + :size 16) + (xlib:display-finish-output *display*))) + +(defun cube-string (cube) + (if *cube-display-number* + (write-to-string (group-number (cube-group cube))) + (format-expand *group-formatters* *group-format* (cube-group cube)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; cube management ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun destroy-cubes (ml) + (setf (mode-line-cubes ml) (remove-if (lambda (cube) + (xlib:destroy-window (cube-window cube)) t) + (mode-line-cubes ml))) + (xlib:display-finish-output *display*)) + +(defun find-cube-window (win) + (second (xlib:window-plist win))) + +(defun find-cube-number (ml num) + (find-if (lambda (cube) + (eq (cube-number cube) num)) + (mode-line-cubes ml))) + +;; Delete a cube window and remove it from *cubes* +;; Apply key on each cube and delete if = arg +(defun delete-cube (ml arg key) + (setf (mode-line-cubes ml) (remove-if (lambda (cube) + (if (eq (funcall (symbol-function key) cube) arg) + (progn (xlib:destroy-window (cube-window cube)) t))) + (mode-line-cubes ml))) + ;; (unless (zerop (length (mode-line-cubes ml))) (rearrange-cubes ml)) + (xlib:display-finish-output *display*)) + +(defun rearrange-cubes (ml &optional (x 0)) + (and + (mode-line-cubes ml) + (progn (setf (xlib:drawable-x (cube-window (first (mode-line-cubes ml)))) + x) + (reduce (lambda (cube1 cube2) + (let* ((cube1-win (cube-window cube1)) + (cube1-width (xlib:drawable-width cube1-win)) + (cube2-x (+ (xlib:drawable-x cube1-win) cube1-width))) + (setf (xlib:drawable-x (cube-window cube2)) cube2-x)) + cube2) + (mode-line-cubes ml)) + (redraw-cubes ml) + (xlib:display-finish-output *display*)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Stumpwm environment ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun group-mode-lines (group) + (mapcar (lambda (head) (head-mode-line head)) + (screen-heads (group-screen group)))) + +(defun group-exists-p (group) + (and (find group (screen-groups (group-screen group))) t)) + +(defun create-mode-line-cubes (ml) + (destroy-cubes ml) + (dolist (w (sort-groups (group-screen (mode-line-current-group ml)))) + (add-cube-group ml w))) + +;; redraw cube windows +(defun redraw-cubes (ml) + (mapcar (lambda (cube) + (setf (cube-state cube) + (if (eq (cube-number cube) (group-number (current-group))) + :toggled + :normal)) + (draw-cube cube)) + (mode-line-cubes ml))) + +(defun cube-switch (new old) + (let ((old-group-exists (group-exists-p old))) + (mapcar (lambda (ml) + ;; FIXME: cache group number + (if (not (find-cube-number ml (group-number new))) + (add-cube-group ml new) + (redraw-cubes ml)) + (if (not old-group-exists) + (delete-cube ml old 'cube-group))) + (group-mode-lines new)))) + +(defun add-cube-switch-hook () + ;; Group Switch hook + ;; To be moved to switch-to-group in group.lisp or update-mode-line + (add-hook *focus-group-hook* (lambda (new old) (cube-switch new old)))) + diff --git a/mode-line.lisp b/mode-line.lisp index d6a30ee..f0a40a5 100644 --- a/mode-line.lisp +++ b/mode-line.lisp @@ -45,6 +45,7 @@ cc height factor + cubes (mode :stump)) (defun mode-line-gc (ml) @@ -373,13 +374,15 @@ critical." (when (eq (mode-line-mode ml) :stump) (let* ((*current-mode-line-formatters* *screen-mode-line-formatters*) (*current-mode-line-formatter-args* (list ml)) - (string (mode-line-format-string ml))) + (string (mode-line-format-string ml)) + width) (when (or force (not (string= (mode-line-contents ml) string))) (setf (mode-line-contents ml) string) (resize-mode-line ml) - (render-strings (mode-line-screen ml) (mode-line-cc ml) - *mode-line-pad-x* *mode-line-pad-y* - (split-string string (string #\Newline)) '()))))) + (setf width (render-strings (mode-line-screen ml) (mode-line-cc ml) + *mode-line-pad-x* *mode-line-pad-y* + (split-string string (string #\Newline)) '())) + (rearrange-cubes ml (+ width 10)))))) (defun find-mode-line-window (xwin) (dolist (s *screen-list*) @@ -502,6 +505,8 @@ critical." (update-mode-line-color-context (head-mode-line head)) (resize-mode-line (head-mode-line head)) (xlib:map-window (mode-line-window (head-mode-line head))) + (add-cube-switch-hook) + (create-mode-line-cubes (head-mode-line head)) (redraw-mode-line (head-mode-line head)) (dformat 3 "modeline: ~s~%" (head-mode-line head)) ;; setup the timer diff --git a/stumpwm.asd b/stumpwm.asd index a1c095a..709f4ba 100644 --- a/stumpwm.asd +++ b/stumpwm.asd @@ -48,6 +48,7 @@ (:file "fdump") (:file "time") (:file "mode-line") + (:file "mode-line-cubes") (:file "color") (:file "module") (:file "stumpwm")