Newer
Older
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: Utility
;;; --------------------------------------------------------------------------
;;;
;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
;;;
;;; 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, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; --------------------------------------------------------------------------
(in-package :clfswm)
Philippe Brochard
committed
;;; Configuration file
(defun xdg-config-home ()
(aif (getenv "XDG_CONFIG_HOME")
(pathname-directory (concatenate 'string it "/"))
(append (pathname-directory (user-homedir-pathname)) '(".config"))))
Philippe Brochard
committed
Philippe Brochard
committed
(let ((saved-conf-name nil))
(defun conf-file-name (&optional alternate-name)
(unless (and saved-conf-name (not alternate-name))
(let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc")))
(etc-conf (probe-file #p"/etc/clfswmrc"))
(config-user-conf (probe-file (make-pathname :directory (append (xdg-config-home) '("clfswm"))
:name "clfswmrc")))
Philippe Brochard
committed
(alternate-conf (and alternate-name (probe-file alternate-name))))
Philippe Brochard
committed
(setf saved-conf-name (or alternate-conf config-user-conf user-conf etc-conf))))
(print saved-conf-name)
saved-conf-name))
Philippe Brochard
committed
(defun load-contrib (file)
"Load a file in the contrib directory"
(let ((truename (merge-pathnames file *contrib-dir*)))
(if (probe-file truename)
(load truename :verbose nil)
(format t " File not found!~%"))))
Philippe Brochard
committed
(defun reload-clfswm ()
"Reload clfswm"
(format t "~&-*- Reloading CLFSWM -*-~%")
(asdf:oos 'asdf:load-op :clfswm)
Philippe Brochard
committed
Philippe Brochard
committed
;;;----------------------------
;;; Lisp image part
;;;----------------------------
Philippe Brochard
committed
(defun build-lisp-image (dump-name)
#+:CLISP (ext:saveinitmem dump-name :init-function (lambda () (clfswm:main) (ext:quit)) :executable t)
#+:SBCL (sb-ext:save-lisp-and-die dump-name :toplevel 'clfswm:main :executable t)
#+:CMU (ext:save-lisp dump-name :init-function (lambda () (clfswm:main) (ext:quit)) :executable t)
#+:CCL (ccl:save-application dump-name :toplevel-function (lambda () (clfswm:main) (ccl:quit)) :prepend-kernel t)
#+:ECL (c:build-program dump-name :epilogue-code '(clfswm:main)))
Philippe Brochard
committed
(defun query-yes-or-no (formatter &rest args)
(let ((rep (query-string (apply #'format nil formatter args) "" '("Yes" "No"))))
(or (string= rep "")
(char= (char rep 0) #\y)
(char= (char rep 0) #\Y))))
Philippe Brochard
committed
(defun banish-pointer ()
"Move the pointer to the lower right corner of the screen"
(with-placement (*banish-pointer-placement* x y)
(xlib:warp-pointer *root* x y)))
;;; Root functions utility
Philippe Brochard
committed
(defun show-current-root ()
(when *have-to-show-current-root*
(let ((*notify-window-placement* *show-current-root-placement*))
(notify-message *show-current-root-delay* *show-current-root-message*))))
(defun select-generic-root (fun restart-menu)
(no-focus)
(let* ((current-root (find-root (current-child)))
(parent (find-parent-frame (root-original current-root))))
(when parent
(setf (frame-child parent) (funcall fun (frame-child parent)))
(let ((new-root (find-root (frame-selected-child parent))))
(setf (current-child) (aif (root-current-child new-root)
it
(frame-selected-child parent))))))
(show-all-children t)
Philippe Brochard
committed
(show-current-root)
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
(if restart-menu
(open-menu (find-menu 'root-menu))
(leave-second-mode)))
(defun select-next-root ()
"Select the next root"
(select-generic-root #'rotate-list nil))
(defun select-previous-root ()
"Select the previous root"
(select-generic-root #'anti-rotate-list nil))
(defun select-next-root-restart-menu ()
"Select the next root"
(select-generic-root #'rotate-list t))
(defun select-previous-root-restart-menu ()
"Select the previous root"
(select-generic-root #'anti-rotate-list t))
(defun rotate-root-geometry-generic (fun restart-menu)
(no-focus)
(funcall fun)
(show-all-children t)
Philippe Brochard
committed
(show-current-root)
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
(if restart-menu
(open-menu (find-menu 'root-menu))
(leave-second-mode)))
(defun rotate-root-geometry-next ()
"Rotate root geometry to next root"
(rotate-root-geometry-generic #'rotate-root-geometry nil))
(defun rotate-root-geometry-previous ()
"Rotate root geometry to previous root"
(rotate-root-geometry-generic #'anti-rotate-root-geometry nil))
(defun rotate-root-geometry-next-restart-menu ()
"Rotate root geometry to next root"
(rotate-root-geometry-generic #'rotate-root-geometry t))
(defun rotate-root-geometry-previous-restart-menu ()
"Rotate root geometry to previous root"
(rotate-root-geometry-generic #'anti-rotate-root-geometry t))
(defun exchange-root-geometry-with-mouse ()
"Exchange two root geometry pointed with the mouse"
(open-notify-window '("Select the first root to exchange"))
(wait-no-key-or-button-press)
(wait-mouse-button-release)
(close-notify-window)
(multiple-value-bind (x1 y1) (xlib:query-pointer *root*)
(open-notify-window '("Select the second root to exchange"))
(wait-no-key-or-button-press)
(wait-mouse-button-release)
(close-notify-window)
(multiple-value-bind (x2 y2) (xlib:query-pointer *root*)
(exchange-root-geometry (find-root-by-coordinates x1 y1)
(find-root-by-coordinates x2 y2))))
(show-all-children)
Philippe Brochard
committed
(show-current-root)
(leave-second-mode))
(defun change-current-root-geometry ()
"Change the current root geometry"
(let* ((root (find-root (current-child)))
(x (query-number "New root X position" (root-x root)))
(y (query-number "New root Y position" (root-y root)))
(w (query-number "New root width" (root-w root)))
(h (query-number "New root height" (root-h root))))
(setf (root-x root) x (root-y root) y
(root-w root) w (root-h root) h)
(show-all-children)
Philippe Brochard
committed
(show-current-root)
(leave-second-mode)))
(defun display-all-frame-info ()
(with-all-frames (*root-frame* frame)
(display-frame-info frame)))
(defun display-all-root-frame-info ()
(with-all-root-child (root)
(display-frame-info root)))
Philippe Brochard
committed
(defun place-window-from-hints (window)
"Place a window from its hints"
(let* ((hints (xlib:wm-normal-hints window))
(min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0))
(min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0))
(max-width (or (and hints (xlib:wm-size-hints-max-width hints)) (x-drawable-width *root*)))
(max-height (or (and hints (xlib:wm-size-hints-max-height hints)) (x-drawable-height *root*)))
(rwidth (or (and hints (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-base-width hints)))
(x-drawable-width window)))
(rheight (or (and hints (or (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-base-height hints)))
(x-drawable-height window))))
(setf (x-drawable-width window) (min (max min-width rwidth *default-window-width*) max-width)
(x-drawable-height window) (min (max min-height rheight *default-window-height*) max-height))
(with-placement (*unmanaged-window-placement* x y (x-drawable-width window) (x-drawable-height window))
(setf (x-drawable-x window) x
(x-drawable-y window) y))
(xlib:display-finish-output *display*)))
(defun rename-current-child ()
"Rename the current child"
Philippe Brochard
committed
(let ((name (query-string (format nil "New child name: (last: ~A)" (child-name (current-child)))
(child-name (current-child)))))
(rename-child (current-child) name)
(defun ask-child-transparency (msg child)
(let ((trans (query-number (format nil "New ~A transparency: (last: ~A)"
msg
(* 100 (child-transparency child)))
(* 100 (child-transparency child)))))
(when (numberp trans)
(setf (child-transparency child) (float (/ trans 100))))))
(defun set-current-child-transparency ()
"Set the current child transparency"
Philippe Brochard
committed
(ask-child-transparency "child" (current-child))
(leave-second-mode))
Philippe Brochard
committed
(defun ask-child-border-size (msg child)
(let ((size (query-number (format nil "New ~A border size: (last: ~A)"
msg
(child-border-size child))
(child-border-size child))))
(when (numberp size)
(setf (child-border-size child) size))))
(defun set-current-child-border-size ()
"Set the current child border size"
(ask-child-border-size "child" (current-child))
(leave-second-mode))
(defun renumber-current-frame ()
"Renumber the current frame"
Philippe Brochard
committed
(when (frame-p (current-child))
(let ((number (query-number (format nil "New child number: (last: ~A)" (frame-number (current-child)))
(frame-number (current-child)))))
(setf (frame-number (current-child)) number)
Philippe Brochard
committed
"Add a default frame in the current frame"
Philippe Brochard
committed
(when (frame-p (current-child))
Philippe Brochard
committed
(push (create-frame :name name) (frame-child (current-child)))))
Philippe Brochard
committed
(defun add-frame-in-parent-frame ()
"Add a frame in the parent frame (and reorganize parent frame)"
Philippe Brochard
committed
(let ((parent (find-parent-frame (current-child))))
(when (and parent (not (child-original-root-p (current-child))))
(let ((new-frame (create-frame)))
(pushnew new-frame (frame-child parent))
Philippe Brochard
committed
(awhen (child-root-p (current-child))
(change-root it parent))
Philippe Brochard
committed
(setf (current-child) parent)
(set-layout-once #'tile-space-layout)
Philippe Brochard
committed
(setf (current-child) new-frame)
(leave-second-mode)))))
Philippe Brochard
committed
Philippe Brochard
committed
"Add a placed frame in the current frame"
Philippe Brochard
committed
(when (frame-p (current-child))
(let ((name (query-string "Frame name"))
(x (/ (query-number "Frame x in percent (%)") 100))
(y (/ (query-number "Frame y in percent (%)") 100))
Philippe Brochard
committed
(w (/ (query-number "Frame width in percent (%)" 100) 100))
(h (/ (query-number "Frame height in percent (%)" 100) 100)))
Philippe Brochard
committed
(frame-child (current-child)))))
Philippe Brochard
committed
(defun delete-focus-window-generic (close-fun)
Philippe Brochard
committed
(with-focus-window (window)
Philippe Brochard
committed
(when (child-equal-p window (current-child))
(setf (current-child) (find-current-root)))
Philippe Brochard
committed
(delete-child-and-children-in-all-frames window close-fun)))
Philippe Brochard
committed
Philippe Brochard
committed
(defun delete-focus-window ()
"Close focus window: Delete the focus window in all frames and workspaces"
(delete-focus-window-generic 'delete-window))
Philippe Brochard
committed
"Kill focus window: Destroy the focus window in all frames and workspaces"
Philippe Brochard
committed
(delete-focus-window-generic 'destroy-window))
Philippe Brochard
committed
"Remove the focus window from the current frame"
Philippe Brochard
committed
(with-focus-window (window)
Philippe Brochard
committed
(setf (current-child) (find-current-root))
Philippe Brochard
committed
(hide-child window)
(remove-child-in-frame window (find-parent-frame window))
(show-all-children)))
(defun unhide-all-windows-in-current-child ()
"Unhide all hidden windows into the current child"
Philippe Brochard
committed
(dolist (window (get-hidden-windows))
(unhide-window window)
(process-new-window window)
(map-window window))
(show-all-children))
(defun find-window-under-mouse (x y)
"Return the child window under the mouse"
Philippe Brochard
committed
(let ((win *root*))
Philippe Brochard
committed
(with-all-root-child (root)
Philippe Brochard
committed
(with-all-windows-frames-and-parent (root child parent)
(when (and (or (managed-window-p child parent) (child-equal-p parent (current-child)))
(not (window-hidden-p child))
(in-window child x y))
(setf win child))
(when (in-frame child x y)
(setf win (frame-window child)))))
Philippe Brochard
committed
win))
Philippe Brochard
committed
(defun find-child-under-mouse-in-never-managed-windows (x y)
"Return the child under mouse from never managed windows"
Philippe Brochard
committed
(let ((ret nil))
(dolist (win (xlib:query-tree *root*))
(unless (window-hidden-p win)
(multiple-value-bind (never-managed raise)
(never-managed-window-p win)
(when (and never-managed raise (in-window win x y))
(setf ret win)))))
ret))
Philippe Brochard
committed
(defun find-child-under-mouse-in-child-tree (x y &optional first-foundp)
Philippe Brochard
committed
(let ((ret nil))
Philippe Brochard
committed
(with-all-root-child (root)
Philippe Brochard
committed
(with-all-windows-frames (root child)
(when (and (not (window-hidden-p child))
(in-window child x y))
(if first-foundp
(return-from find-child-under-mouse-in-child-tree child)
(setf ret child)))
(when (in-frame child x y)
(if first-foundp
(return-from find-child-under-mouse-in-child-tree child)
(setf ret child)))))
Philippe Brochard
committed
ret))
Philippe Brochard
committed
Philippe Brochard
committed
(defun find-child-under-mouse (x y &optional first-foundp also-never-managed)
"Return the child under the mouse"
(or (and also-never-managed
(find-child-under-mouse-in-never-managed-windows x y))
(find-child-under-mouse-in-child-tree x y first-foundp)))
;;; Selection functions
(defun clear-selection ()
"Clear the current selection"
(setf *child-selection* nil)
(display-all-root-frame-info))
(defun copy-current-child ()
"Copy the current child to the selection"
Philippe Brochard
committed
(pushnew (current-child) *child-selection*)
(display-all-root-frame-info))
Philippe Brochard
committed
(defun cut-current-child (&optional (show-now t))
Philippe Brochard
committed
(unless (child-root-p (current-child))
(let ((parent (find-parent-frame (current-child))))
(hide-all (current-child))
Philippe Brochard
committed
(copy-current-child)
Philippe Brochard
committed
(remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))
Philippe Brochard
committed
(when parent
Philippe Brochard
committed
(setf (current-child) parent))
Philippe Brochard
committed
(when show-now
(show-all-children t))
Philippe Brochard
committed
(current-child))))
(defun remove-current-child ()
"Remove the current child from its parent frame"
Philippe Brochard
committed
(unless (child-root-p (current-child))
(let ((parent (find-parent-frame (current-child))))
(hide-all (current-child))
(remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))
Philippe Brochard
committed
(when parent
Philippe Brochard
committed
(setf (current-child) parent))
Philippe Brochard
committed
(show-all-children t)
(leave-second-mode))))
Philippe Brochard
committed
(defun delete-current-child ()
Philippe Brochard
committed
"Delete the current child and its children in all frames"
Philippe Brochard
committed
(unless (child-root-p (current-child))
(hide-all (current-child))
(delete-child-and-children-in-all-frames (current-child))
(show-all-children t)
(leave-second-mode)))
(defun paste-selection-no-clear ()
"Paste the selection in the current frame - Do not clear the selection after paste"
Philippe Brochard
committed
(when (frame-p (current-child))
Philippe Brochard
committed
(dolist (child *child-selection*)
Philippe Brochard
committed
(unless (find-child-in-parent child (current-child))
(pushnew child (frame-child (current-child)) :test #'child-equal-p)))
Philippe Brochard
committed
(show-all-children)))
(defun paste-selection ()
"Paste the selection in the current frame"
Philippe Brochard
committed
(when (frame-p (current-child))
Philippe Brochard
committed
(paste-selection-no-clear)
(setf *child-selection* nil)
(display-all-root-frame-info)))
Philippe Brochard
committed
(defun copy-focus-window ()
"Copy the focus window to the selection"
(with-focus-window (window)
Philippe Brochard
committed
(with-current-child (window)
Philippe Brochard
committed
(copy-current-child))))
(defun cut-focus-window ()
"Cut the focus window to the selection"
(with-focus-window (window)
Philippe Brochard
committed
(setf (current-child) (with-current-child (window)
(cut-current-child nil)))
(show-all-children t)))
Philippe Brochard
committed
Philippe Brochard
committed
;;; Maximize function
(defun frame-toggle-maximize ()
"Maximize/Unmaximize the current frame in its parent frame"
Philippe Brochard
committed
(when (frame-p (current-child))
(let ((unmaximized-coords (frame-data-slot (current-child) :unmaximized-coords)))
Philippe Brochard
committed
(if unmaximized-coords
Philippe Brochard
committed
(with-slots (x y w h) (current-child)
Philippe Brochard
committed
(destructuring-bind (nx ny nw nh) unmaximized-coords
Philippe Brochard
committed
(setf (frame-data-slot (current-child) :unmaximized-coords) nil
Philippe Brochard
committed
x nx y ny w nw h nh)))
Philippe Brochard
committed
(with-slots (x y w h) (current-child)
(setf (frame-data-slot (current-child) :unmaximized-coords)
Philippe Brochard
committed
(list x y w h)
x 0 y 0 w 1 h 1))))
Philippe Brochard
committed
(show-all-children)
Philippe Brochard
committed
(leave-second-mode)))
Philippe Brochard
committed
;;; CONFIG - Identify mode
(defun identify-key ()
"Identify a key"
(let* ((done nil)
(font (xlib:open-font *display* *identify-font-string*))
(window (xlib:create-window :parent *root*
:x 0 :y 0
Philippe Brochard
committed
:width (- (xlib:screen-width *screen*) (* *border-size* 2))
:height (* 5 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font)))
:background (get-color *identify-background*)
Philippe Brochard
committed
:border-width *border-size*
:border (get-color *identify-border*)
:colormap (xlib:screen-default-colormap *screen*)
:event-mask '(:exposure)))
(gc (xlib:create-gcontext :drawable window
:foreground (get-color *identify-foreground*)
:background (get-color *identify-background*)
:font font
:line-style :solid)))
(setf (window-transparency window) *identify-transparency*)
(labels ((print-doc (msg hash-table-key pos code state)
(let ((function (find-key-from-code hash-table-key code state)))
(when (and function (fboundp (first function)))
(xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* pos (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
(format nil "~A ~A" msg (documentation (first function) 'function))))))
(clear-pixmap-buffer window gc)
(setf (xlib:gcontext-foreground gc) (get-color *identify-foreground*))
(xlib:draw-glyphs *pixmap-buffer* gc 5 (+ (xlib:max-char-ascent font) 5)
(format nil "Press a key to identify. Press 'q' to stop the identify loop."))
(xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
(format nil "Code=~A KeySym=~S Key=~S Modifiers=~A"
code keysym key modifiers))
(print-doc "Second mode: " *second-keys* 4 code state))
(copy-pixmap-buffer window gc))
(handle-identify-key (&rest event-slots &key root code state &allow-other-keys)
(declare (ignore event-slots root))
(let* ((modifiers (state->modifiers state))
(key (keycode->char code state))
(keysym (keysym->keysym-name (keycode->keysym code modifiers))))
Philippe Brochard
committed
(setf done (and (equal key #\q) (equal modifiers *default-modifiers*)))
(dbg code keysym key modifiers)
(print-key code state keysym key modifiers)
(force-output)))
(handle-identify (&rest event-slots &key display event-key &allow-other-keys)
(declare (ignore display))
(case event-key
(:key-press (apply #'handle-identify-key event-slots) t)
(:exposure (print-key nil nil nil nil nil)))
t))
(xgrab-pointer *root* 92 93)
(map-window window)
(format t "~&Press 'q' to stop the identify loop~%")
(print-key nil nil nil nil nil)
(force-output)
(unwind-protect
(loop until done do
Philippe Brochard
committed
(with-xlib-protect (:Identify-Loop nil)
(when (xlib:event-listen *display* *loop-timeout*)
(xlib:process-event *display* :handler #'handle-identify))
(xlib:display-finish-output *display*)))
(progn
(xlib:destroy-window window)
(xlib:close-font font)
(xgrab-pointer *root* 66 67))))))
Philippe Brochard
committed
(let ((all-symbols (collect-all-symbols)))
(defun eval-from-query-string ()
"Eval a lisp form from the query input"
(let ((form (query-string (format nil "Eval Lisp <~A> " (package-name *package*))
"" all-symbols))
(result nil))
(when (and form (not (equal form "")))
(let ((printed-result
(with-output-to-string (*standard-output*)
(setf result (handler-case
(loop for i in (multiple-value-list
(eval (read-from-string form)))
collect (format nil "~S" i))
(error (condition)
(format nil "~A" condition)))))))
(let ((ret (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
(ensure-list printed-result)
(ensure-list result)))
:width (- (xlib:screen-width *screen*) 2))))
(when (or (search "defparameter" form :test #'string-equal)
(search "defvar" form :test #'string-equal))
(let ((elem (split-string form)))
(pushnew (string-downcase (if (string= (first elem) "(") (third elem) (second elem)))
all-symbols :test #'string=)))
(when (search "in-package" form :test #'string-equal)
Philippe Brochard
committed
(let ((*notify-window-placement* 'middle-middle-root-placement))
(open-notify-window '("Collecting all symbols for Lisp REPL completion."))
(setf all-symbols (collect-all-symbols))
(close-notify-window)))
Philippe Brochard
committed
(when ret
(eval-from-query-string))))))))
(let ((commands (command-in-path)))
(defun run-program-from-query-string ()
"Run a program from the query input"
(labels ((run-program-from-query-string-fun ()
(multiple-value-bind (program return)
(query-string "Run:" "" commands)
(when (and (equal return :return) program (not (equal program "")))
(let ((cmd (concatenate 'string "cd $HOME && exec " program)))
(lambda ()
(do-shell cmd)))))))
(let ((fun (run-program-from-query-string-fun)))
(when fun
(if *in-second-mode*
(progn
(setf *second-mode-leave-function* fun)
(leave-second-mode))
(funcall fun)))))))
;;; Frame name actions
(defun ask-frame-name (msg)
"Ask a frame name"
Philippe Brochard
committed
(let ((all-frame-name nil))
(with-all-frames (*root-frame* frame)
(awhen (frame-name frame) (push it all-frame-name)))
Philippe Brochard
committed
(query-string msg "" all-frame-name)))
;;; Focus by functions
(defun focus-frame-by (frame)
(when (frame-p frame)
(focus-all-children frame (or (find-parent-frame frame (find-current-root))
Philippe Brochard
committed
(show-all-children t)))
(defun focus-frame-by-name ()
"Focus a frame by name"
Philippe Brochard
committed
(focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame:")))
(leave-second-mode))
(defun focus-frame-by-number ()
"Focus a frame by number"
(focus-frame-by (find-frame-by-number (query-number "Focus frame by number:")))
(leave-second-mode))
;;; Open by functions
(defun open-frame-by (frame)
(when (frame-p frame)
(push (create-frame :name (query-string "Frame name")) (frame-child frame))
Philippe Brochard
committed
(show-all-children)))
(defun open-frame-by-name ()
"Open a new frame in a named frame"
Philippe Brochard
committed
(open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in: ")))
(leave-second-mode))
(defun open-frame-by-number ()
"Open a new frame in a numbered frame"
(open-frame-by (find-frame-by-number (query-number "Open a new frame in the group numbered:")))
(leave-second-mode))
;;; Delete by functions
(defun delete-frame-by (frame)
(unless (or (child-equal-p frame *root-frame*)
(child-root-p frame))
Philippe Brochard
committed
(when (child-equal-p frame (current-child))
(setf (current-child) (find-current-root)))
Philippe Brochard
committed
(show-all-children t))
(defun delete-frame-by-name ()
"Delete a frame by name"
Philippe Brochard
committed
(delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame: ")))
(leave-second-mode))
(defun delete-frame-by-number ()
"Delete a frame by number"
(delete-frame-by (find-frame-by-number (query-number "Delete frame by number:")))
(leave-second-mode))
;;; Move by function
Philippe Brochard
committed
(defun move-child-to (child frame-dest)
(when (and child (frame-p frame-dest))
(remove-child-in-frame child (find-parent-frame child))
(pushnew child (frame-child frame-dest))
(focus-all-children child frame-dest)
Philippe Brochard
committed
(show-all-children t)))
(defun move-current-child-by-name ()
"Move current child in a named frame"
Philippe Brochard
committed
(move-child-to (current-child)
Philippe Brochard
committed
(find-frame-by-name
Philippe Brochard
committed
(ask-frame-name (format nil "Move '~A' to frame: " (child-name (current-child))))))
(leave-second-mode))
(defun move-current-child-by-number ()
"Move current child in a numbered frame"
Philippe Brochard
committed
(move-child-to (current-child)
Philippe Brochard
committed
(find-frame-by-number
Philippe Brochard
committed
(query-number (format nil "Move '~A' to frame numbered:" (child-name (current-child))))))
Philippe Brochard
committed
(defun copy-child-to (child frame-dest)
(when (and child (frame-p frame-dest))
(pushnew child (frame-child frame-dest))
(focus-all-children child frame-dest)
Philippe Brochard
committed
(show-all-children t)))
(defun copy-current-child-by-name ()
"Copy current child in a named frame"
Philippe Brochard
committed
(copy-child-to (current-child)
Philippe Brochard
committed
(find-frame-by-name
Philippe Brochard
committed
(ask-frame-name (format nil "Copy '~A' to frame: " (child-name (current-child))))))
(leave-second-mode))
(defun copy-current-child-by-number ()
"Copy current child in a numbered frame"
Philippe Brochard
committed
(copy-child-to (current-child)
Philippe Brochard
committed
(find-frame-by-number
Philippe Brochard
committed
(query-number (format nil "Copy '~A' to frame numbered:" (child-name (current-child))))))
(leave-second-mode))
;;; Show frame info
(defun show-all-frames-info ()
"Show all frames info windows"
(let ((*show-root-frame-p* t))
(show-all-children)
Philippe Brochard
committed
(with-all-root-child (root)
(with-all-frames (root frame)
(raise-window (frame-window frame))
(display-frame-info frame)))))
(defun hide-all-frames-info ()
"Hide all frames info windows"
(show-all-children))
(defun show-all-frames-info-key ()
"Show all frames info windows until a key is release"
(show-all-frames-info)
(wait-no-key-or-button-press)
(hide-all-frames-info))
(defun move-frame (frame parent orig-x orig-y)
(when (and frame parent (not (child-root-p frame)))
(hide-all-children frame)
(with-slots (window) frame
(move-window window orig-x orig-y #'display-frame-info (list frame))
Philippe Brochard
committed
(setf (frame-x frame) (x-px->fl (x-drawable-x window) parent)
(frame-y frame) (y-px->fl (x-drawable-y window) parent)))
Philippe Brochard
committed
(show-all-children)))
(when (and frame parent (not (child-root-p frame)))
(hide-all-children frame)
(with-slots (window) frame
(resize-window window orig-x orig-y #'display-frame-info (list frame))
Philippe Brochard
committed
(setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) frame) parent)
(frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) frame) parent)))
Philippe Brochard
committed
(show-all-children)))
Philippe Brochard
committed
(defun mouse-click-to-focus-generic (root-x root-y mouse-fn)
"Focus the current frame or focus the current window parent
mouse-fun is #'move-frame or #'resize-frame"
(let* ((to-replay t)
Philippe Brochard
committed
(child (find-child-under-mouse root-x root-y))
(parent (find-parent-frame child))
(root-p (child-root-p child)))
Philippe Brochard
committed
(labels ((add-new-frame ()
Philippe Brochard
committed
(when (frame-p child)
(setf parent child
child (create-frame)
Philippe Brochard
committed
mouse-fn #'resize-frame
Philippe Brochard
committed
(current-child) child)
Philippe Brochard
committed
(place-frame child parent root-x root-y 10 10)
(map-window (frame-window child))
(pushnew child (frame-child parent)))))
(when (and root-p *create-frame-on-root*)
(add-new-frame))
(when (and (frame-p child) (not (child-root-p child)))
(funcall mouse-fn child parent root-x root-y))
(when (and child parent
(focus-all-children child parent (not (child-root-p child))))
(when (show-all-children)
(setf to-replay nil)))
Philippe Brochard
committed
(if to-replay
(replay-button-event)
(stop-button-event)))))
(defun mouse-click-to-focus-and-move (window root-x root-y)
Philippe Brochard
committed
"Move and focus the current frame or focus the current window parent.
Philippe Brochard
committed
Or do actions on corners"
Philippe Brochard
committed
(declare (ignore window))
Philippe Brochard
committed
(or (do-corner-action root-x root-y *corner-main-mode-left-button*)
Philippe Brochard
committed
(mouse-click-to-focus-generic root-x root-y #'move-frame)))
(defun mouse-click-to-focus-and-resize (window root-x root-y)
Philippe Brochard
committed
"Resize and focus the current frame or focus the current window parent.
Philippe Brochard
committed
Or do actions on corners"
Philippe Brochard
committed
(declare (ignore window))
Philippe Brochard
committed
(or (do-corner-action root-x root-y *corner-main-mode-right-button*)
Philippe Brochard
committed
(mouse-click-to-focus-generic root-x root-y #'resize-frame)))
Philippe Brochard
committed
(defun mouse-middle-click (window root-x root-y)
"Do actions on corners"
(declare (ignore window))
(or (do-corner-action root-x root-y *corner-main-mode-middle-button*)
(replay-button-event)))
(defun mouse-focus-move/resize-generic (root-x root-y mouse-fn window-parent)
"Focus the current frame or focus the current window parent
mouse-fun is #'move-frame or #'resize-frame.
Focus child and its parents -
For window: set current child to window or its parent according to window-parent"
Philippe Brochard
committed
(labels ((move/resize-managed (child)
(let ((parent (find-parent-frame child)))
Philippe Brochard
committed
(when (and child
(frame-p child)
(child-root-p child))
(setf parent child
child (create-frame)
Philippe Brochard
committed
mouse-fn #'resize-frame)
(place-frame child parent root-x root-y 10 10)
(map-window (frame-window child))
(push child (frame-child parent)))
(focus-all-children child parent window-parent)
Philippe Brochard
committed
(show-all-children)
Philippe Brochard
committed
(typecase child
(xlib:window
(if (managed-window-p child parent)
(funcall mouse-fn parent (find-parent-frame parent) root-x root-y)
Philippe Brochard
committed
(funcall (cond ((or (eql mouse-fn #'move-frame)
(eql mouse-fn #'move-frame-constrained))
#'move-window)
((or (eql mouse-fn #'resize-frame)
(eql mouse-fn #'resize-frame-constrained))
#'resize-window))
Philippe Brochard
committed
child root-x root-y)))
(frame (funcall mouse-fn child parent root-x root-y)))
Philippe Brochard
committed
(show-all-children)))
Philippe Brochard
committed
(move/resize-never-managed (child raise-fun)
(funcall raise-fun child)
Philippe Brochard
committed
(funcall (cond ((eql mouse-fn #'move-frame) #'move-window)
((eql mouse-fn #'resize-frame) #'resize-window))
child root-x root-y)))
Philippe Brochard
committed
(let ((child (find-child-under-mouse root-x root-y nil t)))
Philippe Brochard
committed
(multiple-value-bind (never-managed raise-fun)
Philippe Brochard
committed
(never-managed-window-p child)
Philippe Brochard
committed
(if (and (xlib:window-p child) never-managed raise-fun)
(move/resize-never-managed child raise-fun)
Philippe Brochard
committed
(move/resize-managed child))))))
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
(defun test-mouse-binding (window root-x root-y)
(dbg window root-x root-y)
(replay-button-event))
(defun mouse-select-next-level (window root-x root-y)
"Select the next level in frame"
(declare (ignore root-x root-y))
(let ((frame (find-frame-window window)))
(when (or frame (xlib:window-equal window *root*))
(select-next-level))
(replay-button-event)))
(defun mouse-select-previous-level (window root-x root-y)
"Select the previous level in frame"
(declare (ignore root-x root-y))
(let ((frame (find-frame-window window)))
(when (or frame (xlib:window-equal window *root*))
(select-previous-level))
(replay-button-event)))
(defun mouse-enter-frame (window root-x root-y)
"Enter in the selected frame - ie make it the root frame"
(declare (ignore root-x root-y))
(let ((frame (find-frame-window window)))
(when (or frame (xlib:window-equal window *root*))
(enter-frame))
(replay-button-event)))
(defun mouse-leave-frame (window root-x root-y)
"Leave the selected frame - ie make its parent the root frame"
(declare (ignore root-x root-y))
(let ((frame (find-frame-window window)))
(when (or frame (xlib:window-equal window *root*))
(leave-frame))
(replay-button-event)))
;;;;;,-----
;;;;;| Various definitions
;;;;;`-----
(defun show-help (&optional (browser "dillo") (tempfile "/tmp/clfswm.html"))
"Show current keys and buttons bindings"
(ignore-errors
(produce-doc-html-in-file tempfile))
(sleep 1)
(do-shell (format nil "~A ~A" browser tempfile)))
;;; Bind or jump functions
(let ((key-slots (make-array 10 :initial-element nil))
(current-slot 1))
Philippe Brochard
committed
(defun reset-bind-or-jump-slots ()
(dotimes (i 10)
(setf (aref key-slots i) nil)))
Philippe Brochard
committed
(defun bind-on-slot (&optional (slot current-slot) child)
Philippe Brochard
committed
(setf (aref key-slots slot) (if child child (current-child))))
(defun remove-binding-on-slot ()
"Remove binding on slot"
(setf (aref key-slots current-slot) nil))
(defun jump-to-slot ()
"Jump to slot"
(let ((jump-child (aref key-slots current-slot)))
Philippe Brochard
committed
(when (and jump-child (find-child jump-child *root-frame*))
(unless (find-child-in-all-root jump-child)
(change-root (find-root jump-child) jump-child))
Philippe Brochard
committed
(setf (current-child) jump-child)
(focus-all-children jump-child jump-child)
(show-all-children t))))
"Bind or jump to a slot (a frame or a window)"
Philippe Brochard
committed
(setf current-slot (- n 1))
(let ((default-bind `("b" bind-on-slot
Philippe Brochard
committed
,(format nil "Bind slot ~A on child: ~A" n (child-fullname (current-child))))))
(info-mode-menu (aif (aref key-slots current-slot)
`(,default-bind
("BackSpace" remove-binding-on-slot
Philippe Brochard
committed
,(format nil "Remove slot ~A binding on child: ~A" n (child-fullname (current-child))))
(" - " nil " -")
("Tab" jump-to-slot
,(format nil "Jump to child: ~A" (aif (aref key-slots current-slot)
(child-fullname it)
Philippe Brochard
committed
"Not set - Please, bind it with 'b'")))
("Return" jump-to-slot "Same thing")
("space" jump-to-slot "Same thing"))
(list default-bind))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Useful function for the second mode ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;